Zaki/Password-Manager
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
0f90b816fc98a418c6f828f7fa4ad28ae3ae974c
Password-Manager/mainApk.pas
T
r-zakarya 0c12997ad4 feat(apk): edition de l'entree entiere en un seul enregistrement, et icone choisie dans la galerie 
Un crayon ouvre un formulaire pre-rempli : tous les champs modifiables a la
fois, un seul Save, donc UN commit au lieu d'un par champ ('setfields',
plusieurs PatchEntryField dans le meme CommitChange).

L'icone quitte le menu de l'entree pour ce formulaire : From site (recherche),
Image... (galerie, reduite a 128 px, provenance custom) et Remove.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-09-25 14:57:58 +01:00

4039 lines
154 KiB
ObjectPascal
Raw Blame History

unit mainApk;
{
Client Android en LECTURE SEULE : deverrouiller, chercher, copier.
PLUS AUCUN CONTROLE FMX. Les trois ecrans - deverrouillage, liste, detail -
sont une page HTML rendue par le moteur du systeme (PMA.WebUI,
android-client/web). Cette unite ne tient plus que ce que la page ne peut pas
atteindre : Keystore, biometrie, presse-papiers sensible, FLAG_SECURE, reseau
et dechiffrement.
Le dernier a partir a ete l'ecran de deverrouillage : dans un TEdit Android, le
curseur ne se place pas ou on le touche, ce qui rend un jeton long
incorrigible. Un champ du moteur herite de la saisie du systeme - curseur,
selection, poignees, collage - sans qu'on ecrive une ligne.
Le pont tient en deux gestes : evaluateJavascript pour descendre les donnees,
et une navigation cmd:// interceptee pour remonter les actions. Aucun serveur
local, donc aucun port ouvert sur l'appareil.
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.
}
// CREER UN COFFRE SUR LE TELEPHONE : ESSAIS SEULEMENT.
//
// Un coffre ne ici n'existe nulle part ailleurs : le poste ne le connait pas,
// et personne ne peut le rendre a qui perd son mot de passe. En release le
// telephone ne sait donc que REPRENDRE le coffre du depot ; depot vide ou
// fichier illisible, il ne se passe rien - surtout pas un coffre neuf qui
// masquerait un reglage a corriger.
{$IFDEF DEBUG}
{$DEFINE AllowCreateLocal}
{$ENDIF}
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
System.Diagnostics, System.Rtti, System.NetEncoding, System.DateUtils,
System.Generics.Collections, System.IOUtils, System.Hash, System.StrUtils,
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,
FMX.WebBrowser, System.Messaging, FMX.Media,
FMX.MediaLibrary, FMX.MediaLibrary.Actions,
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.
//
// API DES CONTENUS DE GITEA, pas l'URL du depot : c'est elle qui rend le
// fichier avec son sha. Le client la reconnait a "/api/v1/repos/" et bascule
// sur ce transport (en-tete "token", corps JSON, base64) ; toute autre URL
// est traitee comme l'endpoint PHP.
//
// Sur Windows on garde l'endpoint local : c'est la machine qui l'heberge, et
// rien ne l'oblige a sortir sur le reseau pour se lire elle-meme.
// RELEASE : RIEN. Le depot de l'auteur prerempli chez quelqu'un d'autre
// l'enverrait frapper a une porte qui n'est pas la sienne - et exposerait
// l'adresse d'un depot prive dans chaque APK distribue.
{$IF DEFINED(ANDROID) and DEFINED(DEBUG)}
FIRSTRUN_URL = 'https://git.ai-agents4you.com/api/v1/repos/Zaki/pm_sync/contents/vault-sync.json';
{$ELSEIF DEFINED(ANDROID)}
FIRSTRUN_URL = '';
{$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;
// Sursis avant de jeter le clair quand l'application passe derriere. Assez
// pour aller coller un mot de passe ailleurs et revenir ; trop court pour
// qu'un telephone repose ouvert.
BACKGROUND_GRACE_SECONDS = 30;
// APRES UNE COPIE, plus long : on part coller l'identifiant puis on revient
// chercher le mot de passe, et 30 s n'y suffisaient pas - le coffre se
// reverrouillait au milieu du geste.
COPY_GRACE_SECONDS = 120;
// Duree minimale entre deux rafraichissements de fond.
//
// L'ouverture du coffre en declenchait un CHAQUE FOIS. Verrouiller puis
// rouvrir trois secondes plus tard rappelait donc le serveur, qui ne pouvait
// rien apprendre de neuf : un telechargement complet, et une derivation de
// cle entiere des que l'empreinte ne concordait pas. Le poste ne publie pas
// plusieurs fois par minute ; consulter au plus une fois par quart d'heure
// suffit a ce que la modification arrive sans qu'on y pense.
//
// Ne concerne QUE le rafraichissement automatique. Un appui sur Sync passe
// par un autre chemin et n'attend jamais.
REFRESH_MIN_MINUTES = 15;
// Verification du depot : un battement du minuteur d'inactivite vaut 15 s,
// donc quarante battements font dix minutes. Assez rare pour ne rien peser
// sur une liaison mobile, assez frequent pour qu'on l'apprenne avant d'avoir
// modifie la meme entree des deux cotes.
PROBE_EVERY_TICKS = 40;
// 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.
//
// EN RELEASE ILS N'EXISTENT PAS. Ce sont des commodites de banc d'essai : elles
// evitent de retaper un jeton de quarante caracteres a chaque reinstallation.
// Compilees dans un APK distribue, elles y placeraient en clair de quoi lire le
// depot ET de quoi ouvrir le coffre - il suffirait de decompresser le fichier.
// Le fichier local n'est donc meme pas inclus : une release se compile sans
// lui, et un clone qui ne l'a pas construit quand meme.
//
// EN DEBOGAGE ON LE GARDE, decide le 2026-08-21 : il est hors depot, il
// n'entre dans aucune release, et le jeton qu'il porte n'ouvre qu'un depot
// d'essai. Ce qui vaudrait revocation, c'est un jeton donnant acces a autre
// chose que ce depot.
{$IFDEF DEBUG}
{$I android-client\PMA.LocalConfig.inc}
{$ELSE}
const
FIRSTRUN_TOKEN = '';
TEST_PWD = '';
{$ENDIF}
type
TForm8 = class(TForm)
private
FVault: TVault;
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;
/// Le cache local a refuse de s'ouvrir pendant cette session. Il existe
/// toujours - on ne detruit rien - mais l'interface cesse de proposer une
/// ouverture qui ne peut pas aboutir, et nomme le telechargement pour ce
/// qu'il est : un remplacement.
FVaultUnreadable: Boolean;
// LE MOT DE PASSE DE SYNCHRO TAPE L'EMPORTE SUR CELUI DU CACHE. FPwdShown est
// la derniere valeur que l'app a mise dans le champ ; une valeur differente
// venue de la page est donc un choix de l'utilisateur (FPwdUserSet), que
// l'ouverture du coffre ne doit plus ecraser avec l'ancienne.
FPwdShown: string;
FPwdUserSet: Boolean;
// Synchro a reprendre une fois le nouveau mot de passe verifie.
FSyncAfterVerify: Boolean;
// Reglages d'usage (Settings -> Copy and search), vrais par defaut. Rien de
// secret : un petit fichier en clair dans le dossier prive de l'app.
FUiBackAfterCopy, FUiKbdOnSearch: Boolean;
// Une copie vient d'etre faite : le prochain passage en arriere-plan a
// droit au delai long (COPY_GRACE_SECONDS).
FCopyGrace: Boolean;
// La cle du verrouillage d'ecran est morte (schema retire ou reinitialise) :
// on ouvre la copie de secours, scellee sous le mot de passe.
FRecover: 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;
/// LE MOT DE PASSE DU COFFRE LOCAL, et lui seul.
///
/// Il ouvre `vault-local.json` - un coffre ne sur ce telephone et pas
/// encore publie. Il n'a RIEN a voir avec le secret du depot, meme si
/// l'utilisateur choisit la meme valeur pour les deux : ce sont deux roles,
/// et les confondre faisait qu'un coffre cree ici pretendait sceller le
/// depot avec son propre mot de passe.
///
/// Vide des que le conteneur local disparait - c'est-a-dire des que la
/// reconciliation a passe l'autorite au depot.
FVaultPwd: string;
/// Coordonnees du serveur. Delphi en est le detenteur ; la page ne fait
/// que les editer et les lui renvoyer quand un champ est quitte.
FUrl, FToken, FPwd: string;
/// Le compte de cet appareil. Vide tant qu'aucun coffre local n'existe.
FUser: string;
/// LA CLE DEJA DERIVEE, et de quoi savoir a quel conteneur elle convient.
///
/// Chaque enregistrement rederivait le mot de passe : 600 000 iterations,
/// quatre a six secondes, pour retrouver exactement la cle qui venait de
/// servir. C'est ce qui faisait durer un ajout d'entree cinq a sept
/// secondes. Elle ne se reutilise QUE si le conteneur porte le meme sel et
/// le meme nombre d'iterations - le poste peut avoir rechiffre le sien
/// entre-temps, avec un sel neuf, et une cle qui ne convient pas echouerait
/// sur la marque de GCM en accusant le mot de passe, qui serait bon.
///
/// Rien de nouveau n'est expose : le coffre EN CLAIR est deja en memoire.
/// Elle part au verrouillage, avec lui.
FKey, FKeySalt: TBytes;
FKeyIters: Integer;
/// LES ANCIENNES VERSIONS QUI VIENNENT D'ETRE MONTREES, pour que la copie
/// se demande par un rang. La page en affiche le texte ; elle ne le renvoie
/// jamais - c'est la regle du pont partout ailleurs.
FHistory: TArray<string>;
/// Des modifications sont rangees ici sans avoir atteint le depot.
FPending: Boolean;
/// Le geste etait "synchroniser", et l'ouverture n'a servi qu'a verifier le
/// code de deverrouillage. Remis a faux des sa lecture : sans cela une
/// ouverture ordinaire, plus tard, declencherait une synchronisation que
/// personne n'a demandee.
FSyncAfterOpen: Boolean;
/// Le depot porte quelque chose que nous n'avons pas.
FRemoteAhead: Boolean;
/// Ticks du minuteur d'inactivite depuis la derniere verification du depot.
FTicksSinceProbe: Integer;
/// L'INSTANTANE BRUT, tel qu'il a ete recu. Pas une reserialisation de
/// TVault : celle-ci perdrait tout ce que le telephone ne lit pas -
/// le contenu des pieces jointes, l'avatar, les tombstones - c'est
/// l'invariant de PMA.VaultPatch.
///
/// Il permet d'enregistrer SANS RETIRER le coffre d'abord. Le tirage
/// coutait 3,2 s pour 266 Ko, a chaque sauvegarde, alors qu'on tient deja
/// ce qu'il rapporte. Ce qu'il apportait vraiment, c'etait la certitude de
/// modifier la derniere version publiee - et le sha la donne aussi : si un
/// autre appareil a publie entre-temps, Gitea refuse en 409 et on retire
/// pour de bon.
FPlain: string;
/// Code d'ouverture du cache local, choisi dans l'application. JAMAIS
/// ENREGISTRE : il est vide a chaque lancement et doit etre retape. C'est
/// ce qui le distingue du jeton, dont la persistance est un confort sans
/// consequence puisqu'il n'ouvre que du chiffre.
///
/// Il remplace la protection par verrouillage d'ecran, qu'Android detruit
/// des qu'on change le schema - par conception, et sans recours.
FPin: string;
/// LE CODE SOUS LEQUEL LE CACHE EST REELLEMENT SCELLE - pas celui qui est
/// tape a l'instant.
///
/// Les deux etaient confondus, et toute ecriture du cache rescellait donc
/// sous ce qui trainait dans le champ : une synchronisation, qui ne demande
/// pourtant aucun code, changeait le code. Une frappe de trop suffisait a
/// remplacer 0000 par 00000000, sans que personne ne l'ait decide et sans
/// qu'un mot le dise.
///
/// Seule l'ouverture du coffre y touche desormais - c'est le seul moment ou
/// l'on sait que l'utilisateur connait le code courant.
FPinSealed: string;
// --- l'interface entiere, rendue par le moteur du systeme
FLayWeb: TLayout;
FWeb: TWebBrowser;
/// La page n'accepte rien avant sa fin de chargement. Ce qui arrive trop
/// tot attend ici plutot que de se perdre : au demarrage a froid, le
/// coffre local s'ouvre souvent avant que le moteur ait fini.
FWebReady: Boolean;
FWebPending: TArray<string>;
/// Ce que la page affiche, telle qu'elle le declare. Le bouton retour
/// materiel en depend, et Delphi ne peut pas le deviner.
FWebView: string;
// --- TOTP : la seule ligne vivante, rafraichie chaque seconde
FTotpTimer: TTimer;
FTotpCode: string;
// --- presse-papiers
FClipTimer: TTimer;
FCopied: string;
/// ECHEANCE SUR UNE OPERATION RESEAU. Sans elle, un appel qui ne rend
/// jamais la main laisse l'interface morte et muette : les deux actions
/// restent desactivees, aucun message n'apparait, et rien n'y ramene -
/// c'est arrive avec le serveur local arrete. Les delais de THTTPClient
/// sont censes couvrir ce cas ; celui-ci couvre le jour ou ils ne le font
/// pas, quelle qu'en soit la raison.
FDeadline: TTimer;
// --- verrouillage sur inactivite
FIdleTimer: TTimer;
FLastActivity: TDateTime;
/// Quand l'application est passee derriere. 0 = elle est au premier plan.
FBackgroundAt: TDateTime;
/// Dernier rafraichissement de fond. 0 = jamais, donc le premier a lieu.
FLastRefresh: TDateTime;
procedure Touch;
procedure OnIdleTimer(Sender: TObject);
procedure ShowUnlock;
/// Cree un coffre local vide au nom donne, chiffre sous ce mot de passe.
procedure RegisterLocal(const AUser, APwd: string);
/// Ouvre le conteneur local avec ce mot de passe, et verifie le nom.
procedure LoginLocal(const AUser, APwd: string);
procedure ShowList;
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;
// --- page HTML
procedure BuildWeb;
procedure OnWebLoaded(ASender: TObject);
/// Appelee a chaque navigation du moteur. Les nôtres portent le schema
/// cmd:// ; tout le reste est ignore.
procedure OnWebNavigate(ASender: TObject; const AUrl: string);
procedure HandleWebCommand(const AUrl: string);
/// Envoie un appel a la page, ou le met en attente si elle n'est pas prete.
procedure WebCall(const AJavaScript: string);
procedure PushVault;
procedure PushConfig;
{$IFDEF DEBUG}
procedure CryptoSelfCheck;
procedure PatchSelfCheck;
procedure MergeSelfCheck;
{$ENDIF}
procedure OpenEntry(AVaultIndex: Integer);
/// Ouvre un conteneur en evitant la derivation quand la cle en main
/// convient. Retient au passage celle qui a servi.
function OpenContainer(const AContainer, APwd: string): string;
procedure RefuseChange(const AMessage: string);
procedure CommitChange(const ALabel, AComment, AReopenUuid: string;
const APatch: TFunc<string, string>);
/// Change UN champ de l'entree ouverte. Le nom du champ vient de la page,
/// et n'est donc pas cru sur parole.
procedure SaveEntryField(const AField, ANewValue: string);
/// Plusieurs champs d'un coup, en UN SEUL enregistrement - donc un seul
/// commit dans le depot. Les deux tableaux vont par paires.
procedure SaveEntryFields(const AFields, AValues: TArray<string>);
/// Ajoute une entree au coffre. Le mot de passe voyage par le pont,
/// comme 'setfield' - meme regle, meme journalisation muette.
procedure CreateEntry(const ATitle, ASite, AUser, APwd, AKind,
AFolder, ATotp: string);
function UuidsFromIndexes(const AList: string): TArray<string>;
/// Supprime des entrees, pierres tombales comprises. Sans retour.
/// Liste vide = l'entree ouverte.
procedure DeleteEntriesAt(const AList: string);
/// Duplique des entrees. Liste vide = l'entree ouverte.
procedure DuplicateEntriesAt(const AList: string);
/// Ecrit la piece jointe de la ligne ARowIndex dans Telechargements.
procedure SaveAttachment(ARowIndex: Integer);
/// Fond le coffre ne ici dans le depot, puis passe l'autorite au depot.
procedure ReconcileWithRemote;
/// Publie ce qui a ete enregistre hors connexion. Sans effet s'il n'y a
/// rien en attente.
procedure PublishPending;
/// Demande au depot s'il a bouge, sans rien adopter.
procedure ProbeRemote;
/// LE SECRET QUE LE CACHE DOIT RETENIR, et il n'y en a qu'un a la fois.
///
/// Un coffre ne ici s'ouvre par le mot de passe de son conteneur ; un
/// coffre publie s'ouvre par le secret du depot. Les deux ne coexistent
/// jamais - la reconciliation detruit le conteneur local en passant
/// l'autorite au depot - donc une seule case suffit, a condition de
/// toujours y mettre le bon.
function CachePwd: string;
/// Retire le code de deverrouillage : le cache se rescelle sous la seule
/// cle de l'appareil. Exige un coffre ouvert.
procedure ClearUnlockCode(const AConfirm: string);
/// Pose ou change le code de deverrouillage. Exige un coffre ouvert, donc
/// le code courant deja connu - c'est ce qui empeche un tiers d'en poser un
/// que le proprietaire ne connaitrait pas.
procedure SetUnlockCode(const ANew: string);
procedure PushUnlockMode;
procedure LoadUiPrefs;
procedure SaveUiPrefs;
procedure PushUiPrefs;
procedure ShowSettingsError(const AMsg: string);
// Scanner du QR affiche par le poste (ZXing.Delphi, Apache 2.0).
var
FScanning, FScanBusy: Boolean;
/// L'action de la galerie survit a l'appel : le selecteur d'Android rend
/// la main tout de suite et rappelle plus tard.
FPickIcon: TTakePhotoFromLibraryAction;
FScanFrame: Integer;
FScanLay: TLayout;
FScanImg: TImage;
FCam: TCameraComponent;
FScanLbl: TLabel;
FScanWatch: TTimer;
procedure StartScan;
procedure BeginScan;
procedure StopScan;
procedure DoCancelScan(Sender: TObject);
procedure OnScanWatch(Sender: TObject);
procedure OnCamFrame(Sender: TObject; const ATime: TMediaTime);
function ApplySyncLink(const ALink: string): Boolean;
{$IFDEF ANDROID}
procedure OnActivityMessage(const Sender: TObject; const M: TMessage);
{$ENDIF}
function PwdName: string;
/// Va chercher l'icone du site de l'entree ouverte, ou l'efface.
procedure SetEntryIcon(AFetch: Boolean);
/// CHOISIR UNE IMAGE DE LA GALERIE comme icone. Elle est reduite avant
/// d'entrer dans le coffre - une photo de telephone pese quelques Mo, et
/// une icone se regarde a 32 px dans une liste.
procedure PickEntryIcon;
procedure BeginPickIcon;
procedure IconPicked(AImage: TBitmap);
/// Le depot a bouge, ou ne l'a plus : LE DRAPEAU ET SON TEMOIN ENSEMBLE.
///
/// Ils ne l'etaient pas. FRemoteAhead etait remis a faux a trois endroits -
/// publication, publication differee, rafraichissement - et aucun ne le
/// disait a la page : le point bleu ne savait que s'allumer, et ne
/// s'eteignait qu'au retour suivant sur l'accueil. Un temoin qui reste
/// allume apres qu'on a fait ce qu'il demandait ne demande plus rien, il
/// decore.
procedure SetRemoteAhead(AOn: Boolean);
/// Envoie a la page les anciens mots de passe de l'entree ouverte.
procedure ShowPasswordHistory;
procedure ReopenEntryByUuid(const AUuid: string);
procedure OnClipTimer(Sender: TObject);
procedure OnDeadline(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 StatusErr(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, PMA.WebUI, PMA.VaultPatch,
PMA.SaveFile, PMA.Favicon, System.JSON, System.Permissions,
ZXing.ScanManager, ZXing.BarcodeFormat, ZXing.ReadResult, ZXing.DecodeHintType
{$IFDEF ANDROID}
, Androidapi.JNI.GraphicsContentViewText, Androidapi.JNI.JavaTypes,
Androidapi.Helpers, FMX.Platform.Android, Androidapi.JNI.Os
{$ENDIF};
{$R *.fmx}
/// Passe une chaine a la page. Elle voyage en litteral JavaScript, d'ou
/// l'encodage JSON : une apostrophe ou un retour a la ligne dans un nom de
/// compte casserait sinon l'appel entier.
function JsArg(const AValue: string): string;
var
LStr: TJSONString;
begin
LStr := TJSONString.Create(AValue);
try
Result := LStr.ToJSON;
finally
LStr.Free;
end;
end;
{ ----------------------------------------------------------------------------
Construction
---------------------------------------------------------------------------- }
constructor TForm8.Create(AOwner: TComponent);
var
LEvents: IFMXApplicationEventService;
begin
inherited;
Caption := 'Vault';
// 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.
// Qualifie : TForm a deja une methode PaintBackground, sans parametre, qui
// masque celle de l'unite.
PMA.Theme.PaintBackground(Fill);
// Les barres systeme prennent les deux extremites du degrade, pour que
// l'ecran soit d'un seul tenant.
TintSystemBars(COL_BG_TOP, COL_BG);
SecureScreen; // avant tout affichage de contenu
FVault := TVault.Create;
BuildWeb;
FClipTimer := TTimer.Create(Self);
FClipTimer.Enabled := False;
FClipTimer.Interval := CLIPBOARD_CLEAR_SECONDS * 1000;
FClipTimer.OnTimer := OnClipTimer;
// Plus long que les delais de THTTPClient (15 s), pour que le message precis
// du client reseau arrive le premier quand il fonctionne. Celui-ci n'est que
// le filet.
FDeadline := TTimer.Create(Self);
FDeadline.Enabled := False;
FDeadline.Interval := 25000;
FDeadline.OnTimer := OnDeadline;
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);
// AVANT TOUT RAFRAICHISSEMENT : sans cela le premier tirage remplacerait le
// cache par la version du depot, et ce qui attend ici serait perdu.
FPending := HasPendingFlag;
PushConfig;
WebCall('PM.setVersion("Vault 1.0.0")');
{$IFDEF DEBUG}
// L'effacement du coffre local n'existe QUE dans les versions de debogage.
// La page ne montre le bouton que si Delphi le lui dit, et Delphi ne le dit
// qu'ici : une version publiee n'a donc ni le bouton ni la commande.
WebCall('PM.showDebug()');
{$ENDIF}
ShowUnlock;
{$IFNDEF DEBUG}
// Le journal quitte l'ecran d'accueil, sans quitter l'application : un appui
// long sur la ligne d'etat le ramene. Voir PM.hideLog.
WebCall('PM.hideLog()');
{$ENDIF}
{$IFDEF DEBUG}
// VERIFICATION DU CHIFFREMENT AVANT TOUTE ECRITURE REELLE (§4). Elle depose
// aussi un conteneur sur le disque prive, pour qu'il soit relu par l'AUTRE
// implementation : un aller-retour avec soi-meme ne prouve que la coherence
// interne, et c'est la compatibilite avec le poste qui decide si une
// publication depuis le telephone est lisible ou perdue.
TThread.ForceQueue(nil, procedure begin CryptoSelfCheck; end);
{$ENDIF}
// 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
FVault.Free;
inherited;
end;
procedure TForm8.ShowUnlock;
var
LCanOpen: Boolean;
begin
FLayWeb.Visible := True;
FWeb.Visible := True;
WebCall('PM.showUnlock()');
FWebView := 'unlock';
// Le bouton d'ouverture n'a de sens que si un coffre local existe ET qu'il
// s'est deja laisse ouvrir ; sinon seul le telechargement peut en produire
// un utilisable.
// LE CODE SE DEMANDE ICI, SUR L'ECRAN D'ACCUEIL. Il etait range dans les
// reglages du serveur, ou rien n'indiquait qu'il fallait le retaper : le
// coffre scelle sous un code s'ouvrait donc sans code, echouait, et l'echec
// etait pris pour une corruption - l'appareil proposait de retelecharger un
// coffre qu'il avait parfaitement en main.
WebCall(Format('PM.setPinNeeded(%s)',
[LowerCase(BoolToStr(VaultNeedsPin or FRecover, True))]));
// LES TEMOINS SE REPOSENT ICI, A CHAQUE RETOUR SUR L'ACCUEIL.
//
// Ils n'etaient pousses que par OpenLocalNow : la page n'apprenait donc
// l'attente qu'en OUVRANT le coffre, et l'accueil d'un demarrage a froid
// montrait Sync sans point orange - precisement l'ecran ou l'on decide de
// synchroniser, et le seul moment ou le drapeau relu au demarrage compte.
// Il fallait ouvrir puis reverrouiller pour que le temoin paraisse.
WebCall(Format('PM.setPending(%s)',
[LowerCase(BoolToStr(FPending, True))]));
WebCall(Format('PM.setRemoteAhead(%s)',
[LowerCase(BoolToStr(FRemoteAhead, True))]));
// TROIS SITUATIONS, ET ELLES NE SE DEVINENT PAS DE L'EXTERIEUR :
// 'register' - rien sur cet appareil : il faut creer un coffre (ou en
// telecharger un, ce que les reglages du serveur permettent) ;
// 'login' - un conteneur local existe mais aucun cache utilisable : le
// mot de passe maitre est necessaire, et il coute six secondes ;
// 'open' - un cache est la : l'ouverture est immediate, eventuellement
// derriere le code de deverrouillage.
if HasVault and not FVaultUnreadable then
WebCall('PM.setAuthMode("open")')
else if HasLocalContainer then
WebCall('PM.setAuthMode("login")')
else
{$IFDEF AllowCreateLocal}
WebCall('PM.setAuthMode("register")');
{$ELSE}
// 'download' : meme ecran, sans les champs de creation - il ne reste que
// les reglages du depot et le bouton qui va chercher le coffre.
WebCall('PM.setAuthMode("download")');
{$ENDIF}
PushUnlockMode;
LCanOpen := HasVault and not FVaultUnreadable;
if LCanOpen then
begin
if FRecover then
Status('Screen lock changed - type your ' + PwdName)
else if VaultNeedsPin then
Status('Vault on this device - unlock code required')
else if VaultNeedsAuth then
Status('Vault on this device - protected')
else
Status('Vault on this device');
WebCall('PM.setActions(true, "Sync", false)');
end
else
begin
if HasLocalContainer then
Status('Sign in')
else
Status('No vault on this device yet');
WebCall('PM.setActions(false, "Download vault", false)');
end;
end;
procedure TForm8.ShowList;
begin
FTotpTimer.Enabled := False;
FLayWeb.Visible := True;
FWeb.Visible := True;
FWebView := 'list';
PushVault;
end;
procedure TForm8.OnTotpTick(Sender: TObject);
var
LLeft, LPeriod: Integer;
begin
FTotpCode := TotpNow(FCurrent.Totp, LLeft, LPeriod);
if FTotpCode = '' then
begin
// Un secret illisible ne doit pas passer pour un code : le dire.
WebCall('PM.setTotp("unreadable secret", 0, 30)');
FTotpTimer.Enabled := False;
Exit;
end;
WebCall(Format('PM.setTotp("%s", %d, %d)', [FTotpCode, LLeft, LPeriod]));
end;
procedure TForm8.OnHardwareBack(Sender: TObject; var Key: Word;
var KeyChar: WideChar; Shift: TShiftState);
begin
if Key <> vkHardwareBack then Exit;
if FScanning then
begin
StopScan;
Key := 0;
Exit;
end;
if not FLayWeb.Visible then Exit;
// LE CLAVIER D'ABORD. Quand il est deplie, cette touche est le bouton qui le
// replie - c'est tout ce qu'elle veut dire. La vue web n'etant pas un champ
// que le systeme connait, il ne l'intercepte pas pour nous : on verrouillait
// le coffre pendant que le clavier restait en place, sans plus aucun moyen de
// le refermer.
if HideSoftKeyboard then
begin
Key := 0;
Exit;
end;
// C'est la PAGE qui sait ce qu'elle affiche - Delphi ne le devine pas. Elle
// le declare a chaque changement de vue (cmd://state).
// L'HISTORIQUE SE REFERME D'ABORD, comme les reglages : un voile pose
// par-dessus, et la touche retour le retire sans toucher a ce qu'il couvre.
if FWebView = 'history' then
begin
WebCall('PM.closeHistory()');
Key := 0;
Exit;
end;
// LES REGLAGES SE REFERMENT D'ABORD. Ils sont une parenthese posee par-dessus
// le reste : la touche retour la ferme, elle ne saute pas ce qu'il y a
// derriere.
if FWebView = 'settings' then
begin
WebCall('PM.closeSettings()');
Key := 0;
Exit;
end;
// UNE SELECTION EN COURS S'ANNULE D'ABORD. Verrouiller le coffre parce qu'on
// a voulu annuler un choix serait le contraire de ce que le geste veut dire.
if FWebView = 'select' then
begin
WebCall('PM.clearSelection()');
FWebView := 'list';
Key := 0;
end
else if FWebView = 'detail' then
begin
WebCall('PM.back()');
FWebView := 'list';
Key := 0; // consomme : sinon Android ferme l'application
end
else
begin
LockVault;
Key := 0;
end;
end;
{ ----------------------------------------------------------------------------
La page : liste et detail
---------------------------------------------------------------------------- }
procedure TForm8.BuildWeb;
begin
FLayWeb := TLayout.Create(Self);
FLayWeb.Parent := Self;
FLayWeb.Align := TAlignLayout.Client;
// VISIBLE DES LE DEPART : la page porte maintenant l'ecran de
// deverrouillage, donc il n'y a plus rien d'autre a montrer. Elle n'est
// masquee qu'au passage en arriere-plan, pour ne pas laisser la liste des
// comptes dans l'apercu des applications recentes.
FLayWeb.Visible := True;
FWeb := TWebBrowser.Create(Self);
FWeb.Parent := FLayWeb;
FWeb.Align := TAlignLayout.Client;
FWeb.OnDidFinishLoad := OnWebLoaded;
FWeb.OnShouldStartLoadWithRequest := OnWebNavigate;
FWeb.LoadFromStrings(PageHtml, '');
{$IFDEF ANDROID}
// LIEN DU QR DU POSTE. Au lancement par le lien, il arrive dans l'intent de
// depart ; app deja ouverte (singleTask), il arrive par message. WebCall met
// en attente tant que la page n'est pas chargee.
MainActivity.registerIntentAction(TJIntent.JavaClass.ACTION_VIEW);
TMessageManager.DefaultManager.SubscribeToMessage(TMessageReceivedNotification,
OnActivityMessage);
if (TAndroidHelper.Activity.getIntent <> nil) and
(TAndroidHelper.Activity.getIntent.getDataString <> nil) then
ApplySyncLink(JStringToString(TAndroidHelper.Activity.getIntent.getDataString));
{$ENDIF}
end;
procedure TForm8.OnWebLoaded(ASender: TObject);
var
LCall: string;
begin
FWebReady := True;
for LCall in FWebPending do
FWeb.EvaluateJavaScript(LCall);
SetLength(FWebPending, 0);
end;
/// Empreinte courte d'un secret, pour le journal. On veut savoir LEQUEL des
/// jetons est en place, jamais sa valeur : huit caracteres de son SHA-256
/// suffisent a les distinguer et n'en revelent rien.
function Fingerprint(const ASecret: string): string;
begin
if ASecret = '' then Exit('(vide)');
Result := Copy(THashSHA2.GetHashString(ASecret), 1, 8);
end;
{$IFDEF DEBUG}
/// LES DEUX AUTO-CONTROLES SONT DE DEBOGAGE, corps compris. Leurs declarations
/// l'etaient deja ; leurs implementations ne l'etaient pas, et une release ne
/// compilait donc pas du tout - la classe ne les declarant plus, le corps
/// devenait un membre inconnu. Defaut invisible tant qu'on ne construit qu'en
/// debogage, ce qui a ete le cas jusqu'a l'empaquetage.
///
/// Chiffre un petit conteneur, le relit, et le laisse sur le disque prive pour
/// qu'une autre implementation le verifie. Iterations volontairement basses :
/// ce qu'on eprouve ici est le CABLAGE - cle, IV, place du tag - pas le cout
/// de la derivation, qui a son propre vecteur de test.
procedure TForm8.CryptoSelfCheck;
const
// Points de code : ce fichier n'a pas de BOM, un accent ecrit tel quel y
// devient deux glyphes et la cle derivee ne serait plus celle qu'on croit.
PWD = 'selfcheck-password-'#$00E9#$00E0#$00FC;
ITERS = 1000;
var
LPlain, LContainer, LBack, LPath: string;
LSw: TStopwatch;
begin
try
// Accents EN POINTS DE CODE, comme le mot de passe : le controle croise a
// montre que ce litteral-ci sortait deja abime du compilateur, et un
// aller-retour avec soi-meme ne pouvait pas le voir.
LPlain := '{"version":1,"entries":[{"uuid":"u1","title":"accent '#$00E9#$00E0'"}]}';
LSw := TStopwatch.StartNew;
LContainer := EncryptContainer(LPlain, PWD, ITERS);
LBack := DecryptContainer(LContainer, PWD);
LSw.Stop;
if LBack = LPlain then
Log(Format('selfcheck: encrypt/decrypt round-trip OK (%d ms)',
[LSw.ElapsedMilliseconds]))
else
Log('selfcheck: ROUND-TRIP MISMATCH - encryption is not usable');
// Depose pour relecture externe. Le mot de passe et les iterations sont
// dans le commentaire de tete du fichier de test cote PC, pas ici.
// GetHomePath, comme PMA.Store : sur Android c'est /data/data/<paquet>/
// files, prive a l'application. Documents n'existe pas ici.
//
// QUALIFIE : FMX.Objects declare aussi un TPath - une forme graphique - et
// il vient apres System.IOUtils dans la clause uses, donc c'est lui que le
// compilateur choisit. Le message parle alors d'un « Combine » inconnu, ce
// qui n'oriente pas vers un conflit de noms.
LPath := System.IOUtils.TPath.Combine(
System.IOUtils.TPath.GetHomePath, 'selfcheck.json');
TFile.WriteAllText(LPath, LContainer, TEncoding.UTF8);
Log('selfcheck: container written for cross-check');
PatchSelfCheck;
MergeSelfCheck;
except
on E: Exception do
Log('selfcheck FAILED: ' + E.ClassName + ' - ' + E.Message);
end;
end;
/// Verifie ce que le patch PRESERVE, pas seulement ce qu'il change.
///
/// C'est l'invariant de §4 : un champ que le telephone ne comprend pas doit
/// ressortir intact, sinon une modification faite ici efface silencieusement
/// des donnees chez tous les autres appareils. On le controle sur un champ
/// inconnu de TVault et sur une piece jointe, qui sont precisement les deux
/// que la reserialisation naive perdrait.
procedure TForm8.PatchSelfCheck;
const
SNAP =
'{"version":1,"username":"test","folders":[{"name":"f"}],' +
'"entries":[' +
'{"uuid":"u1","title":"a","password":"old","updated_at":"2020-01-01T00:00:00Z",' +
'"attachments":[{"filename":"x.pdf","content_b64":"KEEPME"}],' +
'"champ_inconnu":"KEEPTOO"},' +
'{"uuid":"u2","title":"b","password":"other"}],' +
'"tombstones":[{"uuid":"u9"}]}';
var
LOut: string;
LRoot: TJSONObject;
LEntry: TJSONObject;
LOk: Boolean;
begin
try
LOut := PatchEntryField(SNAP, 'u1', 'password', 'NEW');
LRoot := TJSONObject.ParseJSONValue(LOut) as TJSONObject;
try
LEntry := (LRoot.GetValue<TJSONArray>('entries').Items[0]) as TJSONObject;
LOk := (LEntry.GetValue<string>('password') = 'NEW')
and (LEntry.GetValue<string>('updated_at') <> '2020-01-01T00:00:00Z')
and (LEntry.GetValue<string>('champ_inconnu') = 'KEEPTOO')
and (LOut.Contains('KEEPME')) // piece jointe intacte
and (LOut.Contains('"tombstones"')) // et le reste du document
and (LOut.Contains('"other"')); // l'autre entree non touchee
if LOk then Log('selfcheck: patch keeps what it does not understand')
else Log('selfcheck: PATCH LOSES DATA - do not enable writing');
finally
LRoot.Free;
end;
except
on E: Exception do
Log('selfcheck patch FAILED: ' + E.ClassName + ' - ' + E.Message);
end;
end;
/// Redessine le detail d'une entree retrouvee par son uuid.
///
/// PAR UUID ET NON PAR INDICE : le coffre vient d'etre remplace par celui du
/// serveur, et rien ne garantit que la meme entree occupe le meme rang - un
/// tri se fait sur le nom affiche, qu'une autre machine a pu changer.
/// Verifie les QUATRE regles de la fusion, celles dont un ecart se paierait en
/// entrees perdues ou ressuscitees. Elle ne tourne jamais contre un vrai coffre
/// avant d'avoir tourne ici.
procedure TForm8.MergeSelfCheck;
const
LOCAL =
'{"entries":[' +
'{"uuid":"only-local","updated_at":"2026-01-01T00:00:00.000Z"},' +
'{"uuid":"both","updated_at":"2026-06-01T00:00:00.000Z","title":"newer here"},' +
'{"uuid":"killed-there","updated_at":"2026-01-01T00:00:00.000Z"},' +
'{"uuid":"revived","updated_at":"2026-07-01T00:00:00.000Z"}],' +
'"tombstones":[]}';
REMOTE =
'{"avatar_b64":"KEEPME","entries":[' +
'{"uuid":"only-remote","updated_at":"2026-01-01T00:00:00.000Z",' +
'"attachments":[{"content_b64":"KEEPTOO"}]},' +
'{"uuid":"both","updated_at":"2026-02-01T00:00:00.000Z","title":"older"},' +
'{"uuid":"killed-there","updated_at":"2026-01-01T00:00:00.000Z"},' +
'{"uuid":"revived","updated_at":"2026-01-01T00:00:00.000Z"}],' +
'"tombstones":[' +
'{"uuid":"killed-there","deleted_at":"2026-05-01T00:00:00.000Z"},' +
'{"uuid":"revived","deleted_at":"2026-05-01T00:00:00.000Z"}]}';
function Find(const AArr: TJSONArray; const AUuid: string): TJSONObject;
var
I: Integer;
begin
Result := nil;
for I := 0 to AArr.Count - 1 do
if (AArr.Items[I] is TJSONObject) and
((AArr.Items[I] as TJSONObject).GetValue<string>('uuid', '') = AUuid) then
Exit(AArr.Items[I] as TJSONObject);
end;
var
LOut: string;
LRoot: TJSONObject;
LArr: TJSONArray;
LOk: Boolean;
begin
try
LOut := MergeSnapshots(LOCAL, REMOTE);
LRoot := TJSONObject.ParseJSONValue(LOut) as TJSONObject;
if LRoot = nil then
begin
Log('merge selfcheck: result is not JSON');
Exit;
end;
try
LArr := LRoot.GetValue('entries') as TJSONArray;
LOk := True;
// Ce que le distant seul portait survit, contenu des pieces jointes
// compris - c'est la raison pour laquelle il sert de base.
LOk := LOk and (Find(LArr, 'only-remote') <> nil);
LOk := LOk and (LRoot.GetValue<string>('avatar_b64', '') = 'KEEPME');
// Ce que le local seul portait est ajoute.
LOk := LOk and (Find(LArr, 'only-local') <> nil);
// Meme uuid des deux cotes : le plus recent gagne.
LOk := LOk and (Find(LArr, 'both') <> nil) and
(Find(LArr, 'both').GetValue<string>('title', '') = 'newer here');
// Pierre tombale posterieure a l'entree : elle disparait.
LOk := LOk and (Find(LArr, 'killed-there') = nil);
// Pierre tombale ANTERIEURE : l'entree a ete ressuscitee volontairement,
// et la retuer effacerait ce geste.
LOk := LOk and (Find(LArr, 'revived') <> nil);
if LOk then Log('merge selfcheck: the four rules hold')
else Log('merge selfcheck: FAILED - ' + Copy(LOut, 1, 400));
finally
LRoot.Free;
end;
except
on E: Exception do
Log('merge selfcheck FAILED: ' + E.ClassName + ' - ' + E.Message);
end;
end;
{$ENDIF}
procedure TForm8.ReopenEntryByUuid(const AUuid: string);
var
I: Integer;
begin
for I := 0 to FVault.Count - 1 do
if FVault.Entry(I).Uuid = AUuid then
begin
OpenEntry(I);
Exit;
end;
// Disparue du distant entre-temps : la liste est deja a jour, on y reste.
WebCall('PM.back()');
end;
/// Change le mot de passe de l'entree ouverte, et publie.
///
/// TIRER, MODIFIER, RECHIFFRER, PUBLIER - dans cet ordre, et sur l'instantane
/// DU SERVEUR, pas sur le cache local. C'est ce qui remplace la fusion : ce
/// qu'on ne touche pas est deja la version la plus recente de tout le monde.
///
/// Le seul conflit possible est qu'un autre appareil publie entre notre lecture
/// et notre ecriture. Gitea le refuse alors sur le sha (409), et on recommence
/// tout - y compris le dechiffrement, parce que le contenu a change. Trois
/// essais : au-dela, c'est que l'autre appareil publie en boucle, et insister
/// n'y changerait rien.
/// REFUSER, ET RENDRE LA MAIN. Les deux, toujours, et c'est pour cela que ca
/// tient en une procedure plutot qu'en deux appels cote a cote : la page
/// desactive son bouton en envoyant, donc un refus qui se contente de parler
/// laisse un formulaire mort avec la saisie derriere. La regle s'est deja fait
/// oublier trois fois - a l'editeur, puis au formulaire de creation.
function TForm8.OpenContainer(const AContainer, APwd: string): string;
var
LSalt, LNewKey, LNewSalt: TBytes;
LIters, LNewIters: Integer;
LSw: TStopwatch;
begin
LSw := TStopwatch.StartNew;
// LA CLE EN MAIN EST CELLE DE L'ANCIEN MOT DE PASSE. La reutiliser quand
// l'utilisateur vient d'en enregistrer un autre ouvrait le depot sans jamais
// essayer celui-ci : un mot de passe faux passait pour bon.
if (not FPwdUserSet) and (FKey <> nil) and ContainerKdfParams(AContainer, LSalt, LIters)
and (LIters = FKeyIters) and (Length(LSalt) = Length(FKeySalt))
and CompareMem(Pointer(LSalt), Pointer(FKeySalt), Length(LSalt)) then
begin
Result := DecryptContainerWithKey(AContainer, FKey);
Log(Format(' opened with the key already in hand, in %d ms',
[LSw.ElapsedMilliseconds]));
Exit;
end;
// DANS DES LOCALES, rangees seulement apres un dechiffrement reussi : les
// parametres `out` de type TBytes sont vides des l'appel, et un essai rate
// effacait la bonne cle - la publication suivante aurait alors re-derive
// avec le mauvais mot de passe.
Result := DecryptContainerEx(AContainer, APwd, LNewKey, LNewSalt, LNewIters);
FKey := LNewKey;
FKeySalt := LNewSalt;
FKeyIters := LNewIters;
Log(Format(' key derived in %d ms', [LSw.ElapsedMilliseconds]));
end;
procedure TForm8.RefuseChange(const AMessage: string);
begin
WebCall('PM.toast(' + JsArg(AMessage) + ')');
WebCall('PM.editDone()');
end;
/// ENREGISTRER UNE MODIFICATION - un seul chemin, deux transports.
///
/// La regle qui tranche : SI UN CONTENEUR LOCAL EXISTE, C'EST LUI L'AUTORITE.
/// Un coffre ne ici n'a pas de depot ; un coffre tire d'un depot n'a pas de
/// conteneur local. Le cas ou les deux coexistent - un coffre local auquel on
/// ajoute ensuite un depot - demande une fusion, et c'est l'etape 4 de la §7.
///
/// APatch recoit le clair et rend le clair modifie. Il ne peut pas etre
/// applique d'avance : le chemin distant doit modifier CE QU'IL VIENT DE
/// TIRER, sinon il ecraserait ce qu'un autre appareil a publie entre-temps.
///
/// AReopenUuid vide = revenir a la liste plutot qu'a une entree.
procedure TForm8.CommitChange(const ALabel, AComment, AReopenUuid: string;
const APatch: TFunc<string, string>);
begin
// CHAQUE REFUS REND LA MAIN A LA PAGE. Ces gardes se contentaient d'un
// message : l'editeur restait ouvert avec ses boutons desactives, donc
// Cancel lui-meme ne repondait plus - un cul-de-sac dont rien ne sortait.
if FBusy then
begin
RefuseChange('Busy - wait for the current operation');
Exit;
end;
// DEUX SECRETS, DEUX EXIGENCES. Un coffre ne ici n'ecrit que son conteneur
// local et n'a donc pas besoin du secret du depot ; un coffre publie n'a pas
// de conteneur local et n'a donc pas besoin du sien.
if HasLocalContainer then
begin
if FVaultPwd = '' then
begin
RefuseChange('Vault password missing - open the vault first');
Exit;
end;
end
else if FSyncPwd = '' then
begin
RefuseChange('Sync password missing - open the vault first');
Exit;
end;
SetBusy(True);
TThread.CreateAnonymousThread(
procedure
var
LClient: TSyncClient;
LGet, LPut: TSyncResult;
LPlain, LNew, LBody, LErr: string;
LAttempt: Integer;
LSw: TStopwatch;
LPublished, LLocalOnly, LPatched: Boolean;
begin
LClient := nil;
LErr := '';
LNew := '';
LPublished := False;
LPatched := False;
LLocalOnly := HasLocalContainer;
try
try
// ---------------------------------------------------------------
// 1. MODIFIER ET RANGER ICI. TOUJOURS, ET D'ABORD.
//
// L'enregistrement partait autrefois du reseau : sans lui, rien
// n'etait garde. Or ce que l'utilisateur vient de taper lui appartient
// deja - le publier est une consequence, pas une condition. On ecrit
// donc le cache avant toute chose, et le depot suit quand il peut.
// ---------------------------------------------------------------
LSw := TStopwatch.StartNew;
if LLocalOnly then LPlain := OpenContainer(LoadLocalContainer, FVaultPwd)
else LPlain := FPlain;
if LPlain = '' then
raise Exception.Create('no snapshot in hand - open the vault again');
LNew := APatch(LPlain);
LPatched := True;
Log(Format('save: patch in %d ms', [LSw.ElapsedMilliseconds]));
LSw := TStopwatch.StartNew;
LBody := EncryptContainerWithKey(LNew, FKey, FKeySalt, FKeyIters);
Log(Format('save: re-encrypt in %d ms', [LSw.ElapsedMilliseconds]));
if LLocalOnly then SaveLocalContainer(LBody);
try
SaveVault(LNew, FETag, CachePwd, BiometricAvailable, False,
FPinSealed, FKey, FKeySalt, FKeyIters);
except
on E: Exception do Log(' cache not written: ' + E.Message);
end;
// ---------------------------------------------------------------
// 2. PUBLIER SI ON PEUT. Un echec ici ne perd rien.
// ---------------------------------------------------------------
if LLocalOnly then
begin
// Coffre ne ici : il n'y a pas de depot, donc rien a publier.
LPublished := True;
Log('save: written locally');
end
else
begin
LClient := TSyncClient.Create(FUrl, FToken);
for LAttempt := 1 to 3 do
begin
LSw := TStopwatch.StartNew;
LPut := LClient.Put(LBody, FETag, AComment);
Log(Format('save: PUT %d chars in %d ms',
[Length(LBody), LSw.ElapsedMilliseconds]));
if LPut.Status = ssOK then
begin
FETag := LPut.ETag;
LPublished := True;
SetRemoteAhead(False);
Log('save: published, new sha ' + LPut.ETag);
Break;
end;
if LPut.Status <> ssConflict then
begin
LErr := Format('HTTP %d %s', [LPut.HttpCode, LPut.Error]);
Break;
end;
// LE DISTANT A BOUGE : ON FUSIONNE, on ne rejoue pas.
//
// Rejouer la seule modification en cours sur l'instantane frais
// etait juste tant qu'on ne pouvait ecrire qu'en ligne. Depuis
// qu'on enregistre hors connexion, plusieurs changements peuvent
// attendre ici : n'en rejouer qu'un perdrait les autres.
Log(Format('save: %d - another device published, merging',
[LPut.HttpCode]));
LGet := LClient.Fetch;
if LGet.Status <> ssOK then
begin
LErr := Format('read failed (HTTP %d) %s',
[LGet.HttpCode, LGet.Error]);
Break;
end;
LNew := MergeSnapshots(LNew, OpenContainer(LGet.Container, FSyncPwd));
LBody := EncryptContainerWithKey(LNew, FKey, FKeySalt, FKeyIters);
FETag := LGet.ETag;
// Le cache suit la fusion : sans cela il resterait sur notre
// version d'avant, et le prochain essai repartirait de la.
try
SaveVault(LNew, FETag, CachePwd, BiometricAvailable, False,
FPinSealed, FKey, FKeySalt, FKeyIters);
except
on E: Exception do Log(' cache not written: ' + E.Message);
end;
end;
if (not LPublished) and (LErr = '') then
LErr := 'the remote kept changing - try again';
end;
except
on E: Exception do
begin
LErr := E.ClassName + ': ' + E.Message;
Log('save FAILED: ' + LErr);
end;
end;
TThread.Queue(nil,
procedure
begin
if not LPatched then
begin
// La modification elle-meme n'a pas abouti : rien a adopter, et
// c'est le seul cas ou l'utilisateur perd sa saisie.
WebCall('PM.toast(' + JsArg('Not saved - ' + LErr) + ')');
Exit;
end;
AdoptVault(LNew);
FPending := not LPublished;
SetPendingFlag(FPending);
WebCall(Format('PM.setPending(%s)',
[LowerCase(BoolToStr(FPending, True))]));
if LPublished then
WebCall('PM.toast(' + JsArg(ALabel) + ')')
else
// DIRE LES DEUX : que c'est garde, et que le depot ne le sait pas
// encore. Un simple "echec" ferait retaper ce qui est deja la.
WebCall('PM.toast(' + JsArg(
ALabel + ' - saved here, not published yet') + ')');
end);
finally
LClient.Free;
// LA REMISE EN ETAT EST ICI, PAS DANS LE CHEMIN NOMINAL. Elle etait
// apres la boucle : une exception au rechiffrement ou au PUT la
// sautait, et la ligne restait sur "Saving..." pour toujours - sans
// message, puisque le message aussi etait dans la partie sautee.
TThread.Queue(nil,
procedure
begin
SetBusy(False);
if AReopenUuid <> '' then ReopenEntryByUuid(AReopenUuid)
// Rien a rouvrir : c'est une creation. La page doit quand meme
// reprendre la main, sinon un echec laisse son bouton mort.
else WebCall('PM.editDone()');
end);
end;
end).Start;
end;
procedure TForm8.SaveEntryField(const AField, ANewValue: string);
var
LUuid, LTitle: string;
begin
if FCurrent.Uuid = '' then
begin
RefuseChange('This entry has no uuid - cannot be updated');
Exit;
end;
// LA PAGE NE CHOISIT PAS QUOI ECRIRE. Le nom vient d'elle, mais il traverse
// le pont, et ce qui traverse un pont se traite comme une entree exterieure.
// Ces quatre-la seulement : le reste de l'instantane porte des tombstones,
// des pieces jointes et des horodatages, que PatchEntryField ecraserait sans
// rien y comprendre.
if (AField <> 'title') and (AField <> 'site')
and (AField <> 'username') and (AField <> 'password')
and (AField <> 'folder') and (AField <> 'totp_secret') then
begin
RefuseChange('That field cannot be changed from here');
Exit;
end;
LUuid := FCurrent.Uuid;
LTitle := FCurrent.Display;
CommitChange('Saved: ' + LTitle, AField + ' change from phone', LUuid,
function (APlain: string): string
begin
Result := PatchEntryField(APlain, LUuid, AField, ANewValue);
end);
end;
/// L'EDITION DE L'ENTREE ENTIERE. Un champ a la fois, c'etait un commit par
/// champ : corriger un nom et son adresse laissait deux instantanes dans le
/// depot. Ici les corrections s'appliquent l'une apres l'autre au meme clair,
/// et c'est le resultat qui part.
///
/// Le filtre des noms est celui de SaveEntryField, et pour la meme raison : ce
/// qui traverse le pont se traite comme une entree exterieure.
procedure TForm8.SaveEntryFields(const AFields, AValues: TArray<string>);
var
LUuid, LTitle: string;
I: Integer;
begin
if Length(AFields) = 0 then Exit;
if FCurrent.Uuid = '' then
begin
RefuseChange('This entry has no uuid - cannot be updated');
Exit;
end;
for I := 0 to High(AFields) do
if (AFields[I] <> 'title') and (AFields[I] <> 'site')
and (AFields[I] <> 'username') and (AFields[I] <> 'password')
and (AFields[I] <> 'folder') and (AFields[I] <> 'totp_secret') then
begin
RefuseChange('That field cannot be changed from here');
Exit;
end;
LUuid := FCurrent.Uuid;
LTitle := FCurrent.Display;
CommitChange('Saved: ' + LTitle,
Format('%d field(s) changed from phone', [Length(AFields)]), LUuid,
function (APlain: string): string
var
J: Integer;
begin
Result := APlain;
for J := 0 to High(AFields) do
Result := PatchEntryField(Result, LUuid, AFields[J], AValues[J]);
end);
end;
/// SUPPRIMER - la seule action sans retour depuis le telephone.
///
/// Elle ne met pas a la corbeille : celle du poste ne voyage pas dans la
/// synchronisation, donc s'y arreter ne supprimerait nulle part. Elle retire la
/// ligne ET pose la pierre tombale, ce qui fait disparaitre l'entree du poste
/// au prochain tirage.
///
/// La page demande confirmation avant d'en arriver ici.
/// RECONCILIER - un coffre ne sur le telephone auquel on donne un depot.
///
/// Jusqu'ici les deux situations ne se rencontraient pas : un coffre local
/// n'avait pas de depot, un coffre tire d'un depot n'avait pas de conteneur
/// local. Le jour ou les deux existent, la regle "le conteneur local fait
/// autorite" fait que les enregistrements n'atteignent jamais le depot - et les
/// deux divergent en silence, ce qui est la pire des issues.
///
/// La fusion se fait UNE FOIS, puis le conteneur local est efface : le depot
/// devient l'autorite, et l'appareil se comporte des lors comme n'importe quel
/// autre. C'est ce qui rend la divergence impossible plutot qu'improbable.
///
/// L'ORDRE COMPTE. On publie d'abord, on efface ensuite : l'inverse perdrait le
/// coffre entier si la publication echouait.
/// PUBLIER CE QUI ATTEND ICI.
///
/// L'enregistrement hors connexion garde la modification dans le cache et
/// laisse le depot en arriere. Il faut donc un moment ou l'on rattrape, et
/// c'est la synchronisation - le geste par lequel on demande justement que
/// les deux cotes se reparlent.
///
/// FUSION, PAS ECRASEMENT : le depot a pu bouger pendant qu'on etait hors
/// ligne. MergeSnapshots arbitre entree par entree sur `updated_at`, donc ce
/// qui a ete modifie ailleurs plus recemment survit a notre publication.
procedure TForm8.PublishPending;
begin
if not FPending then Exit;
if FBusy then Exit;
if (FPlain = '') or (FSyncPwd = '') then Exit;
SetBusy(True);
Status('Publishing what was saved offline...');
TThread.CreateAnonymousThread(
procedure
var
LClient: TSyncClient;
LGet, LPut: TSyncResult;
LMerged, LBody, LErr: string;
LAttempt: Integer;
LDone: Boolean;
begin
LClient := TSyncClient.Create(FUrl, FToken);
LDone := False;
LErr := '';
LMerged := FPlain;
try
try
for LAttempt := 1 to 3 do
begin
LGet := LClient.Fetch;
if LGet.Status = ssOK then
begin
LMerged := MergeSnapshots(LMerged,
OpenContainer(LGet.Container, FSyncPwd));
FETag := LGet.ETag;
end
else if LGet.Status = ssNotModified then
// Le depot est reste ou nous l'avions laisse : rien a fondre, il
// ne manque que notre publication.
FETag := LGet.ETag
else
begin
LErr := Format('read failed (HTTP %d) %s', [LGet.HttpCode, LGet.Error]);
Break;
end;
LBody := EncryptContainerWithKey(LMerged, FKey, FKeySalt, FKeyIters);
LPut := LClient.Put(LBody, FETag, 'offline changes from phone');
if LPut.Status = ssOK then
begin
FETag := LPut.ETag;
try
SaveVault(LMerged, FETag, CachePwd, BiometricAvailable, False,
FPinSealed, FKey, FKeySalt, FKeyIters);
except
on E: Exception do Log(' cache not written: ' + E.Message);
end;
LDone := True;
Break;
end;
if LPut.Status <> ssConflict then
begin
LErr := Format('HTTP %d %s', [LPut.HttpCode, LPut.Error]);
Break;
end;
end;
if (not LDone) and (LErr = '') then
LErr := 'the remote kept changing - try again';
except
on E: Exception do LErr := E.ClassName + ': ' + E.Message;
end;
TThread.Queue(nil,
procedure
begin
if LDone then
begin
FPending := False;
SetRemoteAhead(False);
SetPendingFlag(False);
AdoptVault(LMerged);
Log('pending changes published, new sha ' + FETag);
WebCall('PM.setPending(false)');
WebCall('PM.toast("Offline changes published")');
end
else
begin
Log('pending changes not published: ' + LErr);
WebCall('PM.toast(' + JsArg('Still not published - ' + LErr) + ')');
end;
end);
finally
LClient.Free;
TThread.Queue(nil, procedure begin SetBusy(False); end);
end;
end).Start;
end;
procedure TForm8.ReconcileWithRemote;
begin
if FBusy then Exit;
if not HasLocalContainer then
begin
StatusErr('No local vault to reconcile');
Exit;
end;
// LES DEUX SONT REQUIS ICI, ET NULLE PART AILLEURS : c'est le seul moment ou
// le conteneur local et l'instantane du depot se rencontrent.
if FVaultPwd = '' then
begin
StatusErr('Open the vault first');
Exit;
end;
// CE QUI EST DANS LES REGLAGES FAIT FOI quand le coffre n'en porte pas encore.
// Un coffre ne ici n'a jamais vu le depot : son cache ne contient donc aucun
// secret de sync, et c'est le champ des reglages qui le donne. Meme
// precedence que DoSync, pour que les deux ne divergent pas.
if FSyncPwd = '' then FSyncPwd := FPwd;
if FSyncPwd = '' then
begin
StatusErr('Set the sync password in Settings');
Exit;
end;
SetBusy(True);
Status('Reconciling...');
TThread.CreateAnonymousThread(
procedure
var
LClient: TSyncClient;
LGet, LPut: TSyncResult;
LLocal, LRemote, LMerged, LBody, LErr: string;
LAttempt: Integer;
LDone, LFirstPush: Boolean;
begin
LClient := TSyncClient.Create(FUrl, FToken);
LDone := False;
LFirstPush := False;
LErr := '';
try
try
// 1. LE COFFRE LOCAL, sous SON mot de passe.
LLocal := OpenContainer(LoadLocalContainer, FVaultPwd);
// 2. ON JETTE LA CLE QUI VIENT DE SERVIR. Elle appartient au conteneur
// local ; tout ce qui suit concerne le depot, scelle par un autre
// secret. La garder ferait resceller le depot sous le mot de passe du
// coffre local - c'est exactement la confusion qu'on defait ici, et
// elle rendrait l'instantane illisible pour le poste.
FKey := nil;
FKeySalt := nil;
FKeyIters := 0;
for LAttempt := 1 to 3 do
begin
LGet := LClient.Fetch;
if LGet.Status = ssNoSnapshot then
begin
// Depot vide : rien a fusionner, seulement a publier. Le cas le
// plus frequent - on donne un depot neuf a un coffre.
//
// 404 EST AMBIGU chez Gitea : fichier absent, ou depot prive qu'on
// n'a pas le droit de voir. On ne cherche pas a trancher ici -
// publier tranche pour nous, puisqu'un jeton sans droit echouera au
// PUT et que rien n'aura ete efface d'ici la.
LMerged := LLocal;
LGet.ETag := '';
LFirstPush := True;
end
else if LGet.Status = ssOK then
begin
// Ouvrir le distant pose la cle DU DEPOT dans FKey : c'est elle
// qui servira a le resceller quelques lignes plus bas.
LRemote := OpenContainer(LGet.Container, FSyncPwd);
LMerged := MergeSnapshots(LLocal, LRemote);
end
else
begin
LErr := Format('read failed (HTTP %d) %s', [LGet.HttpCode, LGet.Error]);
Break;
end;
// Depot vide : aucune cle n'a ete tiree de lui, il faut donc la
// deriver du mot de passe de sync. C'est le seul chemin qui paie les
// quelques secondes, et il n'arrive qu'une fois.
if FKey = nil then LBody := EncryptContainer(LMerged, FSyncPwd)
else LBody := EncryptContainerWithKey(LMerged, FKey, FKeySalt, FKeyIters);
LPut := LClient.Put(LBody, LGet.ETag, 'reconciled from phone');
if LPut.Status = ssOK then
begin
FETag := LPut.ETag;
LDone := True;
Break;
end;
if LPut.Status = ssConflict then Continue;
LErr := Format('write failed (HTTP %d) %s', [LPut.HttpCode, LPut.Error]);
Break;
end;
if (not LDone) and (LErr = '') then
LErr := 'the remote kept changing - try again';
if LDone then
begin
// PUBLIE, DONC PLUS BESOIN DU CONTENEUR LOCAL. C'est ce geste qui
// passe l'autorite au depot ; le faire avant la publication aurait
// perdu le coffre.
// Le conteneur local n'existe plus : son mot de passe non plus.
// L'autorite est passee au depot, et c'est le secret de sync qui
// commande desormais.
DropLocalContainer;
FVaultPwd := '';
try
SaveVault(LMerged, FETag, CachePwd, BiometricAvailable, False,
FPinSealed, FKey, FKeySalt, FKeyIters);
except
on E: Exception do Log(' cache not written: ' + E.Message);
end;
if LFirstPush then Log('Reconcile: repository was empty - published')
else Log('Reconcile: merged with the repository');
end;
TThread.Queue(nil,
procedure
begin
if LDone then
begin
AdoptVault(LMerged);
WebCall('PM.toast("Reconciled - the repository is now the source")');
end
else
WebCall('PM.toast(' + JsArg('Not reconciled - ' + LErr) + ')');
end);
except
on E: Exception do
begin
LErr := E.ClassName + ': ' + E.Message;
Log('Reconcile FAILED: ' + LErr);
TThread.Queue(nil, procedure
begin WebCall('PM.toast(' + JsArg('Not reconciled - ' + LErr) + ')'); end);
end;
end;
finally
LClient.Free;
TThread.Queue(nil, procedure begin SetBusy(False); ShowUnlock; end);
end;
end).Start;
end;
/// LES RANGS ENVOYES PAR LA PAGE -> LES UUID CORRESPONDANTS.
///
/// Une liste vide veut dire "l'entree ouverte" : c'est le menu du detail, qui
/// n'a pas de rang a donner. La page n'envoie jamais d'uuid - elle en a un,
/// mais le faire voyager reviendrait a lui laisser designer une ligne que
/// Delphi n'a pas affichee.
function TForm8.UuidsFromIndexes(const AList: string): TArray<string>;
var
LPart: string;
LIdx: Integer;
begin
Result := nil;
if Trim(AList) = '' then
begin
if FCurrent.Uuid <> '' then Result := [FCurrent.Uuid];
Exit;
end;
for LPart in AList.Split([',']) do
begin
LIdx := StrToIntDef(Trim(LPart), -1);
if (LIdx < 0) or (LIdx >= FVault.Count) then Continue;
if FVault.Entry(LIdx).Uuid = '' then Continue;
Result := Result + [FVault.Entry(LIdx).Uuid];
end;
end;
procedure TForm8.DeleteEntriesAt(const AList: string);
var
LUuids: TArray<string>;
begin
LUuids := UuidsFromIndexes(AList);
if Length(LUuids) = 0 then
begin
RefuseChange('Nothing to delete');
Exit;
end;
// UNE SEULE PUBLICATION POUR TOUTES. Le conteneur monte en entier a chaque
// ecriture : supprimer dix entrees une par une couterait dix fois ce trajet,
// et neuf occasions de le voir echouer a mi-chemin.
//
// Pas de rang a rouvrir : les entrees n'existeront plus. AdoptVault ramene la
// liste, ce qui est exactement ou l'on veut se retrouver.
CommitChange(Format('Deleted %d', [Length(LUuids)]),
'entries deleted from phone', '',
function (APlain: string): string
var
I: Integer;
begin
Result := APlain;
for I := 0 to High(LUuids) do
Result := DeleteEntry(Result, LUuids[I]);
end);
end;
/// ENREGISTRER UNE PIECE JOINTE - la derniere chose que le detail savait
/// montrer sans savoir la rendre.
///
/// Le contenu n'est PAS en memoire : TVault le jette a la lecture, et c'est
/// voulu. Il se relit dans l'instantane brut, pour cette entree seulement, au
/// moment ou on le demande.
///
/// Hors du thread principal : quelques mega-octets a decoder puis a ecrire
/// figeraient l'ecran, et le voile d'attente ne se peindrait meme pas.
///
/// CE QUI SORT DE L'APPLICATION SORT DE SA PROTECTION : le fichier atterrit en
/// clair dans Telechargements, lisible par tout ce qui les lit. C'est ce que
/// l'utilisateur demande en appuyant ; le taire serait pire que le dire.
procedure TForm8.SaveAttachment(ARowIndex: Integer);
var
LCaption, LName, LB64, LMime, LUuid: string;
LAttach: Integer;
begin
if FBusy then Exit;
if not DetailRowAt(FCurrent, ARowIndex, LCaption, LName, LAttach) then Exit;
if LAttach < 0 then Exit;
if (FPlain = '') or (FCurrent.Uuid = '') then
begin
WebCall('PM.toast("Open the vault again to save this file")');
Exit;
end;
LUuid := FCurrent.Uuid;
LMime := '';
if LAttach <= High(FCurrent.Attachments) then
LMime := FCurrent.Attachments[LAttach].Mime;
SetBusy(True);
TThread.CreateAnonymousThread(
procedure
var
LBytes: TBytes;
LSaved, LErr: string;
begin
LErr := '';
try
LB64 := AttachmentContent(FPlain, LUuid, LAttach);
if LB64 = '' then
LErr := 'this attachment has no content in the snapshot'
else
begin
LBytes := TNetEncoding.Base64.DecodeStringToBytes(LB64);
LSaved := SaveToDownloads(LName, LMime, LBytes, LErr);
end;
except
on E: Exception do LErr := E.ClassName + ': ' + E.Message;
end;
TThread.Queue(nil,
procedure
begin
SetBusy(False);
if LSaved <> '' then
begin
Log('saved to Downloads: ' + LSaved);
WebCall('PM.toast(' + JsArg('Saved to Downloads: ' + LSaved) + ')');
end
else
begin
Log('save failed: ' + LErr);
WebCall('PM.toast(' + JsArg('Not saved - ' + LErr) + ')');
end;
end);
end).Start;
end;
procedure TForm8.DuplicateEntriesAt(const AList: string);
var
LUuids: TArray<string>;
begin
LUuids := UuidsFromIndexes(AList);
if Length(LUuids) = 0 then
begin
RefuseChange('Nothing to duplicate');
Exit;
end;
CommitChange(Format('Duplicated %d', [Length(LUuids)]),
'entries duplicated from phone', '',
function (APlain: string): string
var
I: Integer;
begin
Result := APlain;
for I := 0 to High(LUuids) do
Result := DuplicateEntry(Result, LUuids[I]);
end);
end;
procedure TForm8.CreateEntry(const ATitle, ASite, AUser, APwd, AKind,
AFolder, ATotp: string);
begin
// Une entree sans rien pour la reconnaitre serait une ligne muette dans la
// liste, et rien ne permettrait de la retrouver pour la corriger.
if (ATitle = '') and (ASite = '') and (AUser = '') then
begin
RefuseChange('Give it at least a name');
Exit;
end;
CommitChange('Added: ' + ATitle, 'new entry from phone', '',
function (APlain: string): string
begin
Result := AddEntry(APlain, ATitle, ASite, AUser, APwd, AKind, AFolder,
ATotp);
end);
end;
function GraceSeconds(AAfterCopy: Boolean): Integer;
begin
if AAfterCopy then Result := COPY_GRACE_SECONDS
else Result := BACKGROUND_GRACE_SECONDS;
end;
function UiPrefsPath: string;
begin
Result := System.IOUtils.TPath.Combine(System.IOUtils.TPath.GetHomePath, 'ui-prefs.txt');
end;
procedure TForm8.LoadUiPrefs;
var
LText: string;
begin
// Retour automatique DECOCHE par defaut : Android ne laisse pas choisir
// l'app qui passe devant, et selon la facon dont Vault a ete ouvert c'est
// l'ecran d'accueil qui revient, pas l'app d'avant.
FUiBackAfterCopy := False;
FUiKbdOnSearch := True;
try
if not TFile.Exists(UiPrefsPath) then Exit;
LText := TFile.ReadAllText(UiPrefsPath);
FUiBackAfterCopy := LText.Contains('back=1');
FUiKbdOnSearch := not LText.Contains('kbd=0');
except
// Illisible : on garde les valeurs par defaut.
end;
end;
procedure TForm8.SaveUiPrefs;
begin
try
TFile.WriteAllText(UiPrefsPath,
'back=' + IfThen(FUiBackAfterCopy, '1', '0') + sLineBreak +
'kbd=' + IfThen(FUiKbdOnSearch, '1', '0'));
except
on E: Exception do Log('ui prefs not saved: ' + E.Message);
end;
end;
procedure TForm8.PushUiPrefs;
begin
WebCall(Format('PM.setUiPrefs(%s, %s)',
[LowerCase(BoolToStr(FUiBackAfterCopy, True)),
LowerCase(BoolToStr(FUiKbdOnSearch, True))]));
end;
procedure TForm8.PushConfig;
var
LUrl, LToken: string;
begin
FUrl := FIRSTRUN_URL;
FToken := FIRSTRUN_TOKEN;
FPwd := TEST_PWD;
FPwdShown := FPwd;
LoadUiPrefs;
PushUiPrefs;
// Ce que l'appareil a retenu l'emporte sur les valeurs de premier lancement.
if LoadDeviceSettings(LUrl, LToken) then
begin
FUrl := LUrl;
if LToken <> '' then FToken := LToken;
end;
Log(Format('config loaded: token %s (%d chars), url %s',
[Fingerprint(FToken), Length(FToken), FUrl]));
WebCall(Format('PM.setConfig(%s, %s, %s, %s)',
[JsArg(FUrl), JsArg(FToken), JsArg(FPwd),
// Replier des champs vides revient a cacher la seule chose a faire.
LowerCase(BoolToStr((FUrl = '') or (FToken = '') or (FPwd = ''), True))]));
end;
procedure TForm8.WebCall(const AJavaScript: string);
begin
if FWebReady then
FWeb.EvaluateJavaScript(AJavaScript)
else
FWebPending := FWebPending + [AJavaScript];
end;
procedure TForm8.PushVault;
begin
WebCall('PM.setVault(' + JsArg(VaultToJson(FVault)) + ')');
end;
procedure TForm8.OpenEntry(AVaultIndex: Integer);
begin
Touch;
if (AVaultIndex < 0) or (AVaultIndex >= FVault.Count) then Exit;
FCurrent := FVault.Entry(AVaultIndex);
WebCall('PM.setDetail(' + JsArg(DetailToJson(FCurrent)) + ')');
FTotpTimer.Enabled := FCurrent.Totp <> '';
if FTotpTimer.Enabled then OnTotpTick(nil); // pas d'attente d'une seconde
end;
procedure TForm8.OnWebNavigate(ASender: TObject; const AUrl: string);
begin
// Le moteur navigue aussi pour charger la page elle-meme.
// L'ACTION SEULE, jamais la requete : elle porte le jeton et le mot de passe.
// Sans cette trace on ne peut pas distinguer « la commande n'arrive pas » de
// « elle arrive et ne fait rien », et les deux se ressemblent de l'exterieur.
if AUrl.StartsWith('cmd://') then
begin
var LDbg := AUrl.Substring(6);
if LDbg.Contains('?') then LDbg := LDbg.Substring(0, LDbg.IndexOf('?')) + '?...';
Log('cmd ' + LDbg);
// AUCUNE EXCEPTION NE SORT DU PONT SANS LAISSER SON NOM.
//
// Le dispatch n'etait garde par rien : une faute dans un handler remontait
// jusqu'a FMX, qui affichait "Access violation" avec une adresse - et le
// journal, lui, ne montrait que la commande recue suivie de rien. On savait
// qu'une commande echouait, jamais laquelle ni pourquoi, et c'est
// exactement la difference entre chercher et trouver.
//
// On attrape, on nomme, on rend la main : une commande fautive ne doit pas
// laisser l'interface voilee derriere une boite de dialogue.
try
HandleWebCommand(AUrl.Substring(6));
except
on E: Exception do
begin
Log('cmd ' + LDbg + ' FAILED: ' + E.ClassName + ' - ' + E.Message);
SetBusy(False);
StatusErr('Command failed - see log');
end;
end;
end;
end;
procedure TForm8.HandleWebCommand(const AUrl: string);
var
LAction, LQuery, LCaption, LValue: string;
LParams: TStringList;
LIdx: Integer;
E: TVaultEntry;
function Param(const AName: string): string;
begin
Result := LParams.Values[AName];
end;
begin
Touch;
LAction := AUrl;
LQuery := '';
if LAction.Contains('?') then
begin
LQuery := LAction.Substring(LAction.IndexOf('?') + 1);
LAction := LAction.Substring(0, LAction.IndexOf('?'));
end;
// Le moteur ajoute parfois une barre finale a une adresse sans chemin.
LAction := LAction.TrimRight(['/']);
LParams := TStringList.Create;
try
LParams.StrictDelimiter := True;
LParams.Delimiter := '&';
LParams.DelimitedText := LQuery;
if LAction = 'touch' then
Exit // Touch a deja eu lieu plus haut
else if LAction = 'state' then
begin
FWebView := Param('view');
if FWebView = 'settings' then PushUnlockMode;
end
else if LAction = 'open' then
OpenEntry(StrToIntDef(Param('i'), -1))
else if LAction = 'lock' then
LockVault
// Les coordonnees du serveur, renvoyees quand un champ est quitte. Delphi
// en reste le detenteur : la page n'est qu'un editeur, et rien ne les lui
// redemande.
else if LAction = 'cfg' then
begin
FUrl := TNetEncoding.URL.Decode(Param('u')).Trim;
FToken := TNetEncoding.URL.Decode(Param('t')).Trim;
// SAVE ENREGISTRE. L'URL et le jeton n'etaient retenus qu'apres une
// reponse du depot : enregistres puis l'app fermee avant tout
// telechargement, ils avaient disparu au lancement suivant. Des valeurs
// fausses se corrigent comme elles se sont tapees ; seul le mot de passe
// de synchro reste hors de ce fichier (il n'y est pas protege).
if (FUrl <> '') and (FToken <> '') then
try
SaveDeviceSettings(FUrl, FToken);
except
on E: Exception do Log('settings not saved: ' + E.Message);
end;
FPwd := TNetEncoding.URL.Decode(Param('p'));
if FPwd <> FPwdShown then
begin
FPwdUserSet := True;
FPwdShown := FPwd;
// COFFRE OUVERT : on verifie tout de suite (DoSync retelecharge et
// dechiffre sous ce mot de passe), et un bon mot de passe est range
// dans le coffre scelle - le seul endroit ou il survit a la fermeture.
if (FPlain <> '') and (FUrl <> '') and (FToken <> '') and (FPwd <> '') then
TThread.ForceQueue(nil, procedure begin DoSync(nil); end);
end;
FPin := TNetEncoding.URL.Decode(Param('c'));
// L'empreinte du mot de passe AUSSI : si une saisie destinee au jeton
// atterrit dans le champ voisin - les deux sont masques - c'est celle-ci
// qui bouge, et le jeton reste inchange sans que rien ne l'explique.
Log(Format('config from page: token %s, pwd %s',
[Fingerprint(FToken), Fingerprint(FPwd)]));
end
else if LAction = 'openvault' then
DoOpenLocal(nil)
else if LAction = 'sync' then
DoSync(nil)
// AVEC 'setfield', LES SEULES COMMANDES QUI TRANSPORTENT UN SECRET. Meme
// regle qu'elle : la valeur ne quitte pas le processus, l'iframe qui la
// porte est detruite, et seule l'action est journalisee - jamais le mot de
// passe, ni sa longueur.
else if LAction = 'register' then
RegisterLocal(TNetEncoding.URL.Decode(Param('u')),
TNetEncoding.URL.Decode(Param('p')))
else if LAction = 'login' then
LoginLocal(TNetEncoding.URL.Decode(Param('u')),
TNetEncoding.URL.Decode(Param('p')))
// La NOUVELLE valeur remonte par le pont - c'est la seule commande qui
// transporte un secret. Elle ne quitte pas le processus, l'iframe qui la
// porte est detruite, et HandleWebCommand ne journalise que l'action.
else if LAction = 'newentry' then
CreateEntry(TNetEncoding.URL.Decode(Param('t')),
TNetEncoding.URL.Decode(Param('s')),
TNetEncoding.URL.Decode(Param('u')),
TNetEncoding.URL.Decode(Param('p')),
TNetEncoding.URL.Decode(Param('k')),
TNetEncoding.URL.Decode(Param('d')),
TNetEncoding.URL.Decode(Param('o')))
else if LAction = 'history' then
ShowPasswordHistory
else if LAction = 'copyhist' then
begin
LIdx := StrToIntDef(Param('k'), -1);
if (LIdx >= 0) and (LIdx <= High(FHistory)) then
begin
LValue := FHistory[LIdx];
LIdx := Pos(#9, LValue);
if LIdx > 0 then
CopyToClipboard(Copy(LValue, LIdx + 1, MaxInt), 'Previous password');
end;
end
else if LAction = 'icon' then
begin
if Param('a') = 'pick' then PickEntryIcon
else SetEntryIcon(Param('a') = 'fetch');
end
{$IFDEF DEBUG}
// JETER LE COFFRE LOCAL - debogage seulement, et absent a la compilation
// en release : la commande n'existe pas, pas plus que le bouton.
else if LAction = 'wipelocal' then
begin
LockVault;
DropLocalVault;
FPending := False;
FETag := '';
FVaultUnreadable := False;
FRecover := False;
Log('DEBUG: local vault dropped');
ShowUnlock;
WebCall('PM.toast("Local vault deleted")');
end
{$ENDIF}
else if LAction = 'pinset' then
begin
// MODE MOT DE PASSE = le code EST le mot de passe du coffre. On le
// verifie : sinon une faute de frappe scellerait sous un "mot de passe"
// que l'utilisateur ne retapera jamais a l'identique.
if (Param('pw') = '1') and
((FPlain = '') or (TNetEncoding.URL.Decode(Param('c')) <> CachePwd)) then
WebCall('PM.toast("Wrong ' + PwdName + '")')
else
SetUnlockCode(TNetEncoding.URL.Decode(Param('c')));
end
// SCANNER LE QR DU POSTE depuis l'app : le scanner du systeme envoyait
// le lien a une recherche web ou demandait avec quoi l'ouvrir.
else if LAction = 'scanqr' then
StartScan
else if LAction = 'pinclear' then
ClearUnlockCode(TNetEncoding.URL.Decode(Param('c')))
else if LAction = 'delentry' then
DeleteEntriesAt(TNetEncoding.URL.Decode(Param('i')))
else if LAction = 'savefile' then
SaveAttachment(StrToIntDef(Param('k'), -1))
else if LAction = 'dupentry' then
DuplicateEntriesAt(TNetEncoding.URL.Decode(Param('i')))
else if LAction = 'setfield' then
SaveEntryField(TNetEncoding.URL.Decode(Param('f')),
TNetEncoding.URL.Decode(Param('v')))
// f0=&v0=&f1=&v1=... : autant de paires que de champs modifies.
else if LAction = 'setfields' then
begin
var LF: TArray<string> := [];
var LV: TArray<string> := [];
var LN := 0;
while Param('f' + IntToStr(LN)) <> '' do
begin
LF := LF + [TNetEncoding.URL.Decode(Param('f' + IntToStr(LN)))];
LV := LV + [TNetEncoding.URL.Decode(Param('v' + IntToStr(LN)))];
Inc(LN);
end;
SaveEntryFields(LF, LV);
end
// La page vient de poser le focus sur la recherche : on deplie le clavier.
else if LAction = 'kbd' then
ShowSoftKeyboard
else if LAction = 'uipref' then
begin
FUiBackAfterCopy := Param('back') = '1';
FUiKbdOnSearch := Param('kbd') = '1';
SaveUiPrefs;
end
else if LAction = 'copy' then
begin
// LES SECRETS NE TRANSITENT PAS PAR LE PONT. La page envoie un rang,
// jamais une valeur : depuis la liste, un indice de coffre ; depuis le
// detail, un rang de ligne. Delphi relit le clair chez lui.
if Param('f') = 'totp' then
CopyToClipboard(FTotpCode, '2FA code')
else if Param('f') = 'row' then
begin
if DetailRowAt(FCurrent, StrToIntDef(Param('k'), -1), LCaption, LValue) then
CopyToClipboard(LValue, LCaption);
end
else
begin
LIdx := StrToIntDef(Param('i'), -1);
if (LIdx >= 0) and (LIdx < FVault.Count) then
begin
E := FVault.Entry(LIdx);
if Param('f') = 'user' then CopyToClipboard(E.Username, 'Username')
else if Param('f') = 'rtotp' then
begin
// Calcule a l'instant de la copie : un code se perime en 30 s.
var LLeft, LPeriod: Integer;
var LCode := TotpNow(E.Totp, LLeft, LPeriod);
if LCode <> '' then
CopyToClipboard(LCode, Format('2FA code (%d s left)', [LLeft]))
else
WebCall('PM.toast("Unreadable 2FA secret")');
end
else if E.IsNote then CopyToClipboard(E.Password, 'Content')
else CopyToClipboard(E.Password, 'Password');
end;
end;
end;
finally
LParams.Free;
end;
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;
FTotpTimer.Enabled := False;
FVault.Clear;
// Le tas de la page detient des noms de comptes et, si une entree est
// ouverte, ses valeurs. Masquer la vue ne les efface pas.
WebCall('PM.wipe()');
// Les lignes du detail portent des valeurs EN CLAIR (FRows) : les detruire
// fait partie du verrouillage, pas de l'affichage.
FCurrent := Default(TVaultEntry);
// PAS DE PushConfig HORS DEMARRAGE. Redescendre les coordonnees du serveur
// ecrase ce que l'utilisateur vient de taper - l'auto-verrouillage le faisait
// donc sans le moindre geste de sa part, et le champ jeton semblait ne rien
// retenir. Verrouiller efface le clair ; la configuration n'a rien a y voir.
//
// LA CLE DERIVEE PART AUSSI. Elle ouvre le conteneur a elle seule, sans le
// mot de passe : la garder apres un verrouillage reviendrait a ne pas
// verrouiller. Le sel la suit, sinon la prochaine ouverture croirait tenir
// une cle valable et dechiffrerait avec du vide.
FKey := nil;
FKeySalt := nil;
FKeyIters := 0;
FPlain := '';
FHistory := nil;
// Le mot de passe du coffre local part avec le clair : le garder ouvrirait
// le conteneur sans rien demander.
FVaultPwd := '';
// Le code aussi : le retenir apres un verrouillage reviendrait a ne pas
// verrouiller. Le garde de SaveVault protege le cache d'ici la.
FPinSealed := '';
ShowUnlock;
end;
procedure TForm8.AdoptVault(const APlainJson: string);
begin
FVault.LoadFromJson(APlainJson);
FPlain := APlainJson;
Log(' ' + FVault.LiveCount.ToString + ' entries, ' +
FVault.TrashCount.ToString + ' in trash');
FVaultUnreadable := False;
FRecover := False;
// LE SCELLEMENT VIENT PEUT-ETRE DE CHANGER : telechargement qui scelle sous
// le mot de passe, rescellement apres un verrouillage d'ecran retire... Les
// reglages restaient sur l'ancien libelle tant qu'on ne les rouvrait pas.
PushUnlockMode;
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 FLayWeb.Visible then
PushVault
else
ShowList;
end;
/// INSCRIPTION - un coffre qui nait ici, sans reseau.
///
/// Ce que le poste fait dans SQLite, l'appareil le fait dans un fichier : le
/// conteneur local porte exactement ce que porterait le depot, chiffre sous ce
/// mot de passe. Le poste ne connaitra pas ce compte pour autant - il cree les
/// siens dans sa base, et rien ne les rapproche aujourd'hui.
///
/// LA DERIVATION COUTE QUATRE A SIX SECONDES sur ce telephone : elle ne peut
/// pas rester sur le thread d'interface, sinon l'ecran gele sans rien dire.
procedure TForm8.RegisterLocal(const AUser, APwd: string);
begin
if FBusy then Exit;
{$IFNDEF AllowCreateLocal}
// La page ne propose plus la creation, mais la commande existe toujours :
// elle se refuse ici aussi, pour que l'interdit ne tienne pas qu'a l'ecran.
StatusErr('Download the vault from the repository');
Exit;
{$ENDIF}
if AUser = '' then
begin
StatusErr('Pick a username');
Exit;
end;
// Huit caracteres, comme le poste. Ce mot de passe est la SEULE chose qui
// protege le conteneur - il n'y a pas de serveur derriere pour limiter les
// tentatives, et le fichier est un fichier.
if Length(APwd) < 8 then
begin
StatusErr('Master password: 8 characters at least');
Exit;
end;
// Un coffre existant ne se remplace pas par accident : ce serait perdre tout
// ce qu'il contient, sans retour possible.
if HasLocalContainer or HasVault then
begin
StatusErr('This device already holds a vault');
Exit;
end;
SetBusy(True);
Status('Creating the vault...');
TThread.CreateAnonymousThread(
procedure
var
LPlain, LContainer: string;
begin
try
LPlain := NewEmptySnapshot(AUser);
LContainer := EncryptContainer(LPlain, APwd);
SaveLocalContainer(LContainer);
// Pas d'ETag : rien n'a ete publie. Le cache s'ecrit quand meme, sinon
// la prochaine ouverture redemanderait six secondes de derivation pour
// un coffre vide.
// LE MOT DE PASSE DE CREATION OUVRE LE COFFRE, et c'est le sens qu'on
// attend de lui. Sans cela le cache s'ouvrait sans rien demander : le
// mot de passe ne servait qu'une fois, a la creation, et n'importe qui
// tenant le telephone deverrouille lisait le coffre ensuite.
//
// On le pose donc comme code de deverrouillage - c'est exactement ce
// que ce format sait faire, et il accepte un mot de passe entier aussi
// bien que des chiffres. ARequireAuth a FAUX : les deux protections
// s'excluent, un cache scelle par un code porte VER_PIN.
//
// Il reste retirable en deux appuis depuis les reglages, pour qui
// prefere l'ouverture immediate.
SaveVault(LPlain, '', APwd, False, False, APwd,
FKey, FKeySalt, FKeyIters);
FPinSealed := APwd; // coffre neuf : ce mot de passe est desormais le sien
TThread.Queue(nil,
procedure
begin
SetBusy(False);
FUser := AUser;
// CE MOT DE PASSE NE TOUCHE PAS AU DEPOT. Il scelle le conteneur
// local, rien d'autre. Le secret du depot vit dans les reglages et
// doit etre le meme sur tous les appareils - le remplacer par
// celui-ci ferait publier un instantane que le poste ne saurait
// plus ouvrir.
FVaultPwd := APwd;
Log('Vault created locally for ' + AUser);
AdoptVault(LPlain);
end);
except
on E: Exception do
begin
// LE TEXTE EST PRIS ICI, PAS DANS LA FILE.
//
// TThread.Queue s'execute sur le thread principal bien apres que le
// except a rendu la main - et Delphi libere l'objet E en sortant du
// gestionnaire. Lire E.Message depuis la file etait donc une lecture
// apres liberation : elle rendait un message vide, et parfois une
// violation d'acces qui remontait a FMX sans rien laisser au journal.
// On ne met en file que des chaines, qui, elles, survivent.
var LWhy := E.ClassName + ' - ' + E.Message;
TThread.Queue(nil,
procedure
begin
SetBusy(False);
Log('Register failed: ' + LWhy);
StatusErr('Could not create the vault - see log');
end);
end;
end;
end).Start;
end;
/// CONNEXION - le mot de passe ouvre le conteneur, le nom identifie.
///
/// C'est le dechiffrement qui fait office de verification : un mot de passe
/// faux echoue sur la marque d'authenticite de GCM, sans qu'aucun secret n'ait
/// eu besoin d'etre compare. Le nom, lui, se lit DANS le conteneur une fois
/// ouvert - il ne protege rien, il dit a qui appartient ce coffre.
procedure TForm8.LoginLocal(const AUser, APwd: string);
begin
if FBusy then Exit;
if not HasLocalContainer then
begin
StatusErr('No vault on this device');
Exit;
end;
if APwd = '' then
begin
Status('Master password required');
Exit;
end;
SetBusy(True);
Status('Opening...');
TThread.CreateAnonymousThread(
procedure
var
LPlain, LOwner: string;
LDoc: TJSONObject;
begin
try
FVaultPwd := APwd; // avant l'ouverture : c'est lui qui la fait
Log('login: opening the local container');
LPlain := OpenContainer(LoadLocalContainer, APwd);
Log(Format('login: opened, %d chars', [Length(LPlain)]));
LOwner := '';
LDoc := TJSONObject.ParseJSONValue(LPlain) as TJSONObject;
if LDoc <> nil then
try
LOwner := LDoc.GetValue<string>('username', '');
finally
LDoc.Free;
end;
// Un nom qui ne correspond pas n'est PAS un refus d'acces - le mot de
// passe a deja ouvert le coffre, le mal serait fait. C'est une faute de
// frappe qu'on signale, et le coffre s'ouvre au nom qu'il porte.
if (AUser <> '') and (LOwner <> '') and not SameText(AUser, LOwner) then
TThread.Queue(nil, procedure
begin Log('Vault belongs to ' + LOwner + ', not ' + AUser); end);
Log('login: writing the cache');
SaveVault(LPlain, FETag, APwd, BiometricAvailable, False, FPinSealed,
FKey, FKeySalt, FKeyIters);
Log('login: cache written');
TThread.Queue(nil,
procedure
begin
// LE RETOUR SUR LE THREAD PRINCIPAL N'EST GARDE PAR RIEN, et c'est
// le seul endroit du chemin qui ne l'etait pas : ni le except du
// thread, ni celui du pont ne le couvrent - il s'execute bien apres
// que les deux ont rendu la main. Une faute ici remontait donc a
// FMX, qui montrait "Access violation" pendant que le journal
// s'arretait sans un mot.
try
Log('login: adopting');
SetBusy(False);
if LOwner <> '' then FUser := LOwner else FUser := AUser;
// Meme regle qu'a la creation : ce mot de passe ouvre le
// conteneur local et s'arrete la.
FVaultPwd := APwd;
AdoptVault(LPlain);
Log('login: done');
except
on E: Exception do
begin
SetBusy(False);
Log('login: adopt FAILED: ' + E.ClassName + ' - ' + E.Message);
StatusErr('Could not display the vault - see log');
end;
end;
end);
except
on E: Exception do
begin
// LE TEXTE EST PRIS ICI, PAS DANS LA FILE.
//
// TThread.Queue s'execute sur le thread principal bien apres que le
// except a rendu la main - et Delphi libere l'objet E en sortant du
// gestionnaire. Lire E.Message depuis la file etait donc une lecture
// apres liberation : elle rendait un message vide, et parfois une
// violation d'acces qui remontait a FMX sans rien laisser au journal.
// On ne met en file que des chaines, qui, elles, survivent.
var LWhy := E.ClassName + ' - ' + E.Message;
TThread.Queue(nil,
procedure
begin
SetBusy(False);
Log('Login failed: ' + LWhy);
// GCM echoue a sa verification quand la cle est fausse, et son
// message ne le dit pas. Le cas de loin le plus frequent.
StatusErr('Wrong master password');
end);
end;
end;
end).Start;
end;
procedure TForm8.OpenLocalNow;
var
LPlain, LETag, LPwd: string;
LSw: TStopwatch;
LChainSync, LOk: Boolean;
begin
// LU ET CONSOMME ICI, une fois pour toutes : un drapeau qui survivrait a un
// code faux ferait synchroniser la prochaine ouverture, sans rapport.
LChainSync := FSyncAfterOpen;
FSyncAfterOpen := False;
// CHRONOMETRE EN TROIS TEMPS. Une ouverture depuis le cache doit etre
// instantanee : c'est toute la raison d'etre de PMA.Store. Quand elle ne
// l'est pas, il faut savoir LEQUEL des trois coute - la lecture du fichier
// scelle, la mise en forme vers la page, ou le rafraichissement de fond qui
// suit - sinon on cherche au hasard.
LSw := TStopwatch.StartNew;
// LA CLE REVIENT AVEC LE CACHE, et c'est tout l'objet de l'y avoir mise :
// ouvrir depuis le cache ne derive rien, donc sans cela le PREMIER
// enregistrement de chaque session repayait les quatre secondes et demie.
if FRecover then
LOk := LoadRecoveryVault(LPlain, LETag, LPwd, FKey, FKeySalt, FKeyIters, FPin)
else
LOk := LoadVault(LPlain, LETag, LPwd, FKey, FKeySalt, FKeyIters, FPin);
if LOk then
begin
if FRecover then
begin
FRecover := False;
// RESCELLER TOUT DE SUITE, sous ce qui existe maintenant : un nouveau
// verrouillage d'ecran s'il y en a un (cle neuve, l'ancienne est morte),
// sinon le mot de passe qu'on vient de taper - jamais en clair.
try
if BiometricAvailable then
SaveVault(LPlain, LETag, LPwd, True, True, '', FKey, FKeySalt, FKeyIters)
else
SaveVault(LPlain, LETag, LPwd, False, False, LPwd, FKey, FKeySalt, FKeyIters);
Log('Opened with the vault password after a screen lock change; cache re-sealed');
except
on E: Exception do Log('Re-seal after recovery failed: ' + E.Message);
end;
end;
Log('Vault opened from cache in ' + LSw.ElapsedMilliseconds.ToString + ' ms');
FETag := LETag;
if LETag = '' then
// Sans empreinte, le rafraichissement qui suit ne peut pas savoir que
// rien n'a change : il retelechargera et redechiffrera a chaque
// ouverture. C'est exactement le cout que le cache doit supprimer.
Log(' WARNING: cache has no fingerprint - the refresh will re-derive');
if LPwd <> '' then
begin
// DANS LA CASE QUI CONVIENT. Le cache d'un coffre ne ici porte le mot de
// passe de son conteneur, pas un secret de depot : le ranger dans
// FSyncPwd le ferait servir a sceller l'instantane, ce qu'on vient
// justement de defaire. Et sans cette relecture, FVaultPwd restait vide
// apres une ouverture depuis le cache - la reconciliation refusait alors
// en boucle, "open vault first" alors que le coffre etait ouvert.
if HasLocalContainer then
FVaultPwd := LPwd
else if FPwdUserSet then
begin
// L'utilisateur a enregistre un autre mot de passe de synchro depuis :
// il RESTE dans les reglages (FPwd), mais seul celui du cache - verifie -
// sert au rafraichissement de fond. Le nouveau se verifie par Sync.
FSyncPwd := LPwd;
Log(' sync password set in Settings kept over the cached one');
end
else
begin
FSyncPwd := LPwd;
// ET LES REGLAGES AVEC. C'est ICI que tout passe - a chaque lancement -
// et non par la creation ni par la connexion, qui n'arrivent qu'une
// fois : PushConfig reposait la valeur de premier lancement au
// demarrage, l'ouverture ne la remplacait pas, et DoSync la PREFERE.
FPwd := LPwd;
FPwdShown := FPwd;
WebCall(Format('PM.setConfig(%s, %s, %s, false)',
[JsArg(FUrl), JsArg(FToken), JsArg(FPwd)]));
end;
end;
// LA PROTECTION RATTRAPE LE CACHE. Elle se decidait a l'ecriture seule,
// et une ecriture n'arrive qu'avec un instantane nouveau : un cache pose
// pendant que l'appareil n'avait pas de verrouillage restait en clair
// indefiniment, meme apres en avoir remis un. On le rescelle ici, ou l'on
// tient justement le clair.
// Journalise le verdict MEME quand rien n'est fait : sans cette ligne, un
// rescellement qui n'a pas lieu ne laisse aucune trace, et on ne sait pas
// s'il a echoue ou s'il n'a jamais ete tente.
if VaultNeedsPin then
Log('Cache sealed under the unlock code')
else if not VaultNeedsAuth then
Log('Plain cache; device authentication available: ' +
BoolToStr(BiometricAvailable, True) + ' ' + LastBiometricError);
// LE CODE RESCELLE ICI, ET NULLE PART AILLEURS. Poser un code puis
// synchroniser ne suffisait pas : une synchronisation qui repond 304
// n'ecrit rien, donc le cache restait dans son ancienne forme et le code
// semblait sans effet. L'ouverture, elle, tient le clair a chaque fois.
// Le cache vient de s'ouvrir : le code tape est donc le bon, ou il n'y en
// avait pas. C'est la seule certitude de ce genre dans toute l'application.
if VaultNeedsPin then FPinSealed := FPin;
// PLUS RIEN NE POSE NI NE CHANGE LE CODE ICI.
//
// Deux branches le faisaient, a partir de ce qui trainait dans les champs :
// l'une appliquait un "nouveau code" depose par les reglages, l'autre
// rescellait sous le code tape des que le cache ne l'etait plus. La seconde
// DEFAISAIT LE RETRAIT : on retirait le code, le champ le portait encore,
// et l'ouverture suivante le reposait sans qu'un mot le dise. La premiere
// ouvrait pire - n'importe qui pouvait deposer un nouveau code depuis les
// reglages sans connaitre l'actuel, et c'est le proprietaire qui, en
// ouvrant son coffre, l'appliquait contre lui-meme.
//
// Poser, changer et retirer passent desormais par SetUnlockCode et
// ClearUnlockCode : un geste explicite, coffre deja ouvert, effet immediat.
// Le champ de l'accueil ne veut plus dire qu'une chose : "ouvre avec ceci".
if (not VaultNeedsAuth) and (not VaultNeedsPin) and BiometricAvailable then
begin
try
// Cle NEUVE, obligatoirement : le changement qui vient de ramener la
// protection a tres probablement invalide l'ancienne, et le
// chiffrement ne saurait pas le voir - on scellerait un fichier
// impossible a rouvrir.
SaveVault(LPlain, LETag, LPwd, True, True, FPinSealed,
FKey, FKeySalt, FKeyIters);
if VaultNeedsAuth then
Log('Cache re-sealed under authentication')
else
Log('Re-seal refused: ' + LastStoreError);
except
on E: Exception do Log('Re-seal failed: ' + E.Message);
end;
end;
WebCall(Format('PM.setPending(%s)',
[LowerCase(BoolToStr(FPending, True))]));
WebCall(Format('PM.setRemoteAhead(%s)',
[LowerCase(BoolToStr(FRemoteAhead, True))]));
// Le compteur repart de zero : on vient de regarder le depot, ou de s'en
// passer sciemment. Le sonder dans la foulee ne dirait rien de neuf.
FTicksSinceProbe := 0;
try
LSw := TStopwatch.StartNew;
AdoptVault(LPlain);
if FUiKbdOnSearch then
WebCall('PM.focusSearch()'); // on ouvre pour chercher : clavier pret
Log(' displayed in ' + LSw.ElapsedMilliseconds.ToString + ' ms');
// 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.
// Le geste de depart etait "synchroniser" : on enchaine sur la vraie
// synchronisation - qui publie et reconcilie - et non sur le simple
// rafraichissement de fond, qui ne fait que tirer.
if LChainSync then
TThread.ForceQueue(nil, procedure begin DoSync(nil); end)
else if FSyncPwd = '' then
Log(' no stored sync password - no background refresh')
else if (FLastRefresh > 0) and
(MinutesBetween(Now, FLastRefresh) < REFRESH_MIN_MINUTES) then
Log(Format(' refreshed %d min ago - skipping (min %d)',
[MinutesBetween(Now, FLastRefresh), REFRESH_MIN_MINUTES]))
else
begin
FLastRefresh := Now;
FetchAndDecrypt(FUrl, FToken, FSyncPwd, True);
end;
except
on E: Exception do
begin
// Un coffre local illisible se remplace, il ne se repare pas.
Log('Local vault corrupt: ' + 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.
// Un code faux se retape ; le cache, lui, n'a rien perdu. Le marquer
// illisible retirerait le bouton d'ouverture pour le reste de la session.
if FRecover then
begin
Log('Recovery copy did not open under this password');
ShowUnlock;
StatusErr('Wrong ' + PwdName);
WebCall('PM.focusPin()');
Exit;
end;
// LA CLE VIENT DE MOURIR SOUS NOS YEUX, mais la copie de secours est la :
// on demande le mot de passe au lieu de declarer le coffre illisible.
if LastStoreKeyInvalidated and HasRecoveryVault then
begin
FRecover := True;
Log('Screen lock key destroyed - recovery copy available');
ShowUnlock;
StatusErr('Screen lock changed - type your ' + PwdName);
WebCall('PM.focusPin()');
Exit;
end;
if VaultNeedsPin then
begin
Log('Vault did not open under this unlock code');
ShowUnlock;
StatusErr('Wrong unlock code');
WebCall('PM.focusPin()');
Exit;
end;
FVaultUnreadable := True;
ShowUnlock;
Log('Local vault unreadable: ' + LastStoreError);
// DIRE LAQUELLE DES DEUX. "Illisible" laisse croire a une corruption, donc
// a une perte - alors que le coffre est intact dans le depot et qu'il n'y a
// qu'a le reprendre. Quand le systeme a lui-meme detruit la cle parce que
// le verrouillage d'ecran a ete retire ou reinitialise, il faut le dire :
// c'est une consequence attendue d'un geste que l'utilisateur a fait, pas
// une panne.
if LastStoreKeyInvalidated then
begin
StatusErr('Device protection changed - download the vault again');
WebCall('PM.toast("This phone''s screen lock was removed or reset, so ' +
'Android destroyed the key that sealed the local copy. ' +
'Nothing is lost - the vault is in the repository.")');
end
else
StatusErr('Local vault unreadable - see log');
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;
// NE PAS TENTER CE QUI NE PEUT QUE RATER. Un code absent n'est pas un coffre
// abime : l'essayer quand meme marquait le cache illisible et transformait le
// bouton en "Download vault", ce qui donnait a croire que le code avait
// detruit le cache alors qu'il le protegeait.
if VaultNeedsPin and (FPin = '') then
begin
StatusErr('Unlock code required');
WebCall('PM.focusPin()');
Exit;
end;
// PLUS DE VERROUILLAGE D'ECRAN : la cle qui scelle le cache est morte, et
// demander l'empreinte ne pourrait que repondre "indisponible". La copie de
// secours s'ouvre au mot de passe.
if (not FRecover) and VaultNeedsAuth and HasRecoveryVault and
(not BiometricAvailable) then
begin
FRecover := True;
Log('No screen lock any more - recovery copy available');
ShowUnlock;
end;
if FRecover then
begin
if FPin = '' then
begin
StatusErr('Screen lock changed - type your ' + PwdName);
WebCall('PM.focusPin()');
Exit;
end;
OpenLocalNow;
Exit;
end;
// 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('Authenticating...');
AuthenticateThen('Unlock the vault',
procedure(AOutcome: TBioOutcome)
begin
case AOutcome of
boOK: OpenLocalNow;
boCancelled: Status('Cancelled');
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('Authentication unavailable at launch - cache kept');
Log(' ' + LastBiometricError);
Status('Authentication unavailable - try again');
end
else
begin
// ON N'EFFACE PLUS, MEME ICI. C'etait le dernier endroit ou
// l'application detruisait le cache, sur la foi d'un verdict qui
// s'est deja revele fragile aujourd'hui. Le garder ne coute que
// quelques centaines de kilo-octets, et un telechargement le
// remplace de toute facon. Desormais RIEN ne detruit le cache :
// seule une ecriture reussie le remplace.
FVaultUnreadable := True;
Log('No usable protection on this device - vault kept but unreadable');
Log(' ' + LastBiometricError);
ShowUnlock;
Status('Screen lock missing - download again to replace the cache');
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('Authentication failed: ' + LastBiometricError);
Status('Authentication failed');
end;
end);
end;
procedure TForm8.DoSync(Sender: TObject);
var
LUrl, LTok, LPwd: string;
begin
if FBusy then Exit;
LUrl := FUrl;
LTok := FToken;
// Ce qui est tape l'emporte : c'est ainsi qu'on corrige un mot de passe
// range qui ne convient plus.
LPwd := FPwd;
if LPwd = '' then LPwd := FSyncPwd;
if (LUrl = '') or (LTok = '') then
begin
ShowSettingsError('Set the repository first - scan the QR shown on the PC,'
+ ' or type the URL and the token');
Exit;
end;
if LPwd = '' then
begin
ShowSettingsError('Sync password required');
Exit;
end;
WebCall('PM.clearLog()');
// SYNCHRONISER DEMANDE UN COFFRE OUVERT DES QU'IL Y EN A UN SUR L'APPAREIL.
//
// Deux raisons, et elles se rejoignent : la reconciliation a besoin du secret
// qui ouvre le conteneur local, et un cache scelle par un code exige que ce
// code ait ete verifie. Ni l'un ni l'autre ne s'obtient sans ouvrir - seul
// LoadVault sait si le code est bon, et seul le cache rend le secret.
//
// NE PAS SE CONTENTER DE REFUSER. Le bouton Sync ne vit que sur l'accueil, et
// une fois le coffre ouvert on est sur la liste, ou il n'existe pas :
// repondre "ouvre d'abord" fermait la seule porte, et l'ouverture qui suivait
// ne relancait rien. On ouvre donc, et OpenLocalNow reprend la
// synchronisation la ou elle s'est arretee.
//
// Un appareil SANS cache n'est pas concerne : c'est le premier
// telechargement, et il n'y a rien a ouvrir.
//
// "COFFRE OUVERT" SE LIT SUR FPlain, PAS SUR LE NOMBRE D'ENTREES. Un coffre
// vide en compte zero, exactement comme un coffre ferme : le garde restait
// donc vrai apres l'ouverture, rearmait la reprise, et l'on tournait en rond
// - le journal repetait "Vault opened from cache" et l'interface clignotait
// sans plus repondre. Le clair en main est le seul signal qui ne ment pas.
if HasVault and (not FVaultUnreadable) and (FPlain = '') then
begin
if VaultNeedsPin and (FPin = '') then
begin
StatusErr('Unlock code required');
WebCall('PM.focusPin()');
Exit;
end;
FSyncAfterOpen := True;
OpenVault(False);
Exit;
end;
// UN MOT DE PASSE DE SYNCHRO CHANGE SE VERIFIE AVANT TOUTE PUBLICATION.
// Publier d'abord chiffrerait l'instantane sous un mot de passe peut-etre
// faux - le poste ne pourrait plus le lire. On retelecharge donc en entier
// (FetchAndDecrypt ignore le sha connu tant que FPwdUserSet) : le
// dechiffrement tranche, puis la synchro reprend si quelque chose attendait.
if FPwdUserSet and not HasLocalContainer then
begin
Log('Sync password changed - verifying it against the repository first');
FSyncAfterVerify := FPending;
FetchAndDecrypt(LUrl, LTok, LPwd, False);
Exit;
end;
// UN COFFRE NE ICI A QUI L'ON DONNE UN DEPOT : il faut fondre les deux, pas
// ecraser l'un par l'autre. Sans cela le conteneur local resterait
// l'autorite, les enregistrements n'atteindraient jamais le depot, et les
// deux divergeraient en silence.
if HasLocalContainer then
begin
ReconcileWithRemote;
Exit;
end;
// CE QUI ATTEND ICI PART D'ABORD. Tirer avant de publier ecraserait notre
// cache par la version du depot, et la modification faite hors connexion
// disparaitrait sans un mot - exactement ce que l'enregistrement hors
// connexion promet d'eviter.
if FPending then
begin
PublishPending;
Exit;
end;
// 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.
//
// MAIS SEULEMENT S'IL Y A UNE PORTE. Exiger une authentification que
// l'appareil ne sait plus rendre enfermait l'utilisateur dehors : le cache
// marque protege refusait de s'ouvrir, et le telechargement qui l'aurait
// remplace etait bloque par la meme condition. Quand plus rien ne peut
// authentifier, ce verrou ne protege personne - le contenu viendra du
// serveur, et c'est le mot de passe de sync qui le garde.
// FPlain et non le nombre d'entrees : un coffre vide en compte zero comme un
// coffre ferme, et l'on redemanderait l'empreinte a un coffre deja ouvert.
if VaultNeedsAuth and (FPlain = '') and BiometricAvailable then
begin
Status('Authenticating...');
AuthenticateThen('Unlock the vault',
procedure(AOutcome: TBioOutcome)
begin
if AOutcome = boOK then
FetchAndDecrypt(LUrl, LTok, LPwd)
else
begin
Log('Sync refused: ' + LastBiometricError);
Status('Authentication required');
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('Downloading...');
// 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,
FKey, FKeySalt, FKeyIters, FPin) 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);
// NOMMER CE QUI EST REELLEMENT ENVOYE. Sur Gitea aucun If-None-Match ne
// part - l'API ne le connait pas, et la comparaison se fait sur le sha
// apres reception. Annoncer l'en-tete faisait chercher un 304 du serveur
// qui ne viendra jamais.
if FETag <> '' then
if LClient.IsGitea then Log(' known sha: ' + FETag)
else Log(' If-None-Match: ' + FETag);
LSw := TStopwatch.StartNew;
// Sha connu IGNORE tant que le mot de passe n'est pas verifie : un
// "rien n'a change" ne dechiffrerait rien, et donc ne prouverait rien.
if FPwdUserSet then LRes := LClient.Fetch('')
else LRes := LClient.Fetch(FETag);
LSw.Stop;
// Un code a zero n'est pas un statut : c'est qu'aucune reponse HTTP
// n'est arrivee. Ecrit tel quel, il se lisait comme un vrai code rendu
// par le serveur, ce qui envoie chercher la cause du mauvais cote.
// LE SERVEUR A REPONDU : LE CHIEN DE GARDE N'A PLUS LIEU D'ETRE.
//
// Il mesurait la duree TOTALE, alors que son message dit "no reply from
// the server". Sur un coffre devenu gros, la reponse arrivait en une
// seconde et les vingt suivantes partaient dans la derivation de la cle
// puis l'affichage - il criait donc a l'absence de reponse alors que
// tout avait reussi, cache ecrit compris. Un faux echec est pire qu'un
// vrai : il apprend a se mefier de ce que l'application raconte.
//
// Desarme des que le statut est connu, quel qu'il soit : ce qui suit ne
// depend plus du reseau, et le voile sera leve par le finally.
TThread.Queue(nil, procedure begin FDeadline.Enabled := False; end);
if LRes.HttpCode > 0 then
Log(' HTTP ' + LRes.HttpCode.ToString + ' in ' +
LSw.ElapsedMilliseconds.ToString + ' ms')
else
Log(' no HTTP reply after ' + LSw.ElapsedMilliseconds.ToString + ' ms');
// LES COORDONNEES SONT RETENUES DES QUE LE TRANSPORT A REPONDU, 200
// comme 304 : les deux prouvent l'adresse et le jeton, seul le corps
// differe. Elles ne l'etaient que sur le chemin du 200, et depuis que
// la comparaison de sha fonctionne une synchronisation repond
// presque toujours 304 - donc un jeton fraichement saisi n'etait
// jamais enregistre, et disparaissait a la fermeture.
if LRes.Status in [ssOK, ssNotModified] then
try
SaveDeviceSettings(AUrl, ATok);
except
on E: Exception do
Log(' settings not saved: ' + E.ClassName + ' - ' + E.Message);
end;
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: unchanged, vault already open')
else if LCached <> '' then
begin
Log(' 304: unchanged, vault served from cache');
try
AdoptVault(LCached);
except
on E: Exception do Status('Cache unreadable: ' + 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('No cache - tap again to download');
end;
end);
Exit;
end;
ssNoSnapshot:
begin
// Le serveur repond pareil dans les deux cas, par conception.
Log(' 404: no snapshot OR invalid token');
if not ASilent then
begin
// TRANCHER L'AMBIGUITE : fichier absent, depot ou utilisateur
// inexistant - deux requetes de plus, seulement quand
// quelqu'un attend la reponse.
var LWhy := LClient.Diagnose(404);
if LWhy = '' then LWhy := 'Nothing to download (404)';
Log(' ' + LWhy);
TThread.Queue(nil, procedure begin ShowSettingsError(LWhy); end);
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(' failed: ' + LRes.Error);
// Depot public : refus LOCAL (HttpCode 0), le message dit quoi faire.
if (not ASilent) and (LRes.Status = ssRefused) and (LRes.HttpCode = 0) then
begin
var LPub := LRes.Error;
TThread.Queue(nil, procedure begin ShowSettingsError(LPub); end);
end
else if (not ASilent) and (LRes.HttpCode = 401) then
begin
var LWhy401 := LClient.Diagnose(401);
TThread.Queue(nil, procedure begin ShowSettingsError(LWhy401); end);
end
else if not ASilent then
TThread.Queue(nil, procedure
begin StatusErr('Network failure'); end);
Exit;
end;
end;
Log(' received ' + Length(LRes.Container).ToString + ' bytes');
// LES DEUX EMPREINTES COTE A COTE. Sans cela on ne peut pas trancher
// entre « le distant a change » et « la comparaison ne se declenche
// pas », et les deux se ressemblent parfaitement de l'exterieur.
// LES LONGUEURS AUTANT QUE LES VALEURS. Deux empreintes s'affichaient
// identiques alors que l'egalite les separait : seul un caractere
// invisible peut faire cela, et il ne se voit qu'au compte.
Log(Format(' remote sha: %s (%d chars, known %d)',
[LRes.ETag, Length(LRes.ETag), Length(FETag)]));
// LES COORDONNEES SONT RETENUES ICI, avant le dechiffrement. Un 200
// avec un conteneur en main prouve l'adresse ET le jeton ; le mot de
// passe est une autre affaire, et il n'est de toute facon pas enregistre
// par cet appel.
//
// Elles ne l'etaient qu'apres un dechiffrement reussi, au nom des
// « reglages eprouves ». Consequence : un mot de passe qui ne convient
// pas faisait perdre l'URL et le jeton au lancement suivant, et il
// fallait les retaper - une URL d'API et quarante caracteres de jeton,
// sur un telephone, a chaque essai.
try
SaveDeviceSettings(AUrl, ATok);
except
on E: Exception do
Log(' settings not saved: ' + E.ClassName + ' - ' + E.Message);
end;
if not ASilent then
TThread.Queue(nil, procedure begin Status('Decrypting...'); end);
LSw := TStopwatch.StartNew;
// Volontairement AVANT de retenir l'ETag : un echec ici doit laisser
// FETag vide pour que le prochain essai retelecharge.
LPlain := OpenContainer(LRes.Container, APwd);
LSw.Stop;
FETag := LRes.ETag;
Log(' decrypted in ' + LSw.ElapsedMilliseconds.ToString + ' ms');
// CE QUI ATTEND ICI NE SE FAIT PAS ECRASER. Le rafraichissement
// remplacait le cache par la version du depot : une modification faite
// hors connexion disparaissait alors sans un mot, et c'est exactement
// ce que l'enregistrement hors ligne promet d'eviter.
//
// Le depot vient d'etre lu : ce qu'il portait est ici.
SetRemoteAhead(False);
// On garde le drapeau : fondre ne publie pas.
if FPending and (FPlain <> '') then
begin
LPlain := MergeSnapshots(FPlain, LPlain);
Log(' merged with what is waiting here - still to publish');
end;
// Ecrit APRES un dechiffrement reussi seulement, et avec son ETag :
// les deux doivent rester coherents.
// AUCUNE PROTECTION ICI VEUT DIRE AUCUNE, ET C'EST TROP.
//
// Sans biometrie utilisable et sans code pose, le cache s'ouvrait sans
// rien demander - or il CONTIENT le mot de passe de sync. Qui tient le
// telephone deverrouille obtenait donc le coffre ET le secret du depot.
//
// On le scelle sous le mot de passe qui vient de rapporter le coffre :
// il est deja dans ce fichier, donc cela n'expose rien de neuf, et
// l'utilisateur le connait puisqu'il vient de le taper. C'est aussi la
// seule forme de cache qui survive a une reinitialisation du
// verrouillage d'ecran.
//
// PAS quand l'appareil sait authentifier : VER_PIN et VER_WRAP
// s'excluent, et imposer une frappe a qui a une empreinte serait un
// recul. Retirable en deux appuis depuis les reglages.
var LSeal := FPinSealed;
if (not LCanAuth) and (LSeal = '') then LSeal := APwd;
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 and (LSeal = ''), False, LSeal,
FKey, FKeySalt, FKeyIters);
// SANS CETTE LIGNE LES ECRITURES SUIVANTES SERAIENT REFUSEES : le
// garde de SaveVault interdit de resceller un cache a code sans le
// code, et il le lirait ici comme absent.
if VaultNeedsPin then FPinSealed := LSeal;
Log(' cache now holds sha: ' + FETag);
if VaultNeedsAuth then
Log(' cache written - protected by biometrics/PIN')
else if LCanAuth then
Log(' cache written - plain key (Keystore refused the constraint)')
else
Log(' cache written - NO protection: no authentication here');
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 not written: ' + E.ClassName + ' - ' + E.Message);
end;
TThread.Queue(nil,
procedure
begin
FSyncPwd := APwd; // il vient d'ouvrir un conteneur : il est bon
// Le cache le porte desormais : il redevient la reference.
FPwdUserSet := False;
FPwdShown := FPwd;
if FSyncAfterVerify then
begin
FSyncAfterVerify := False;
TThread.ForceQueue(nil, procedure begin DoSync(nil); end);
end;
try
AdoptVault(LPlain);
except
on E: Exception do
if not ASilent then
Status('Snapshot unreadable: ' + E.Message);
end;
end);
except
on E: Exception do
begin
Log('ERROR ' + 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.
FSyncAfterVerify := False; // rien ne part sous un mot de passe faux
if not ASilent then
TThread.Queue(nil, procedure
begin ShowSettingsError('Wrong sync password - it must be the one set on the PC'); 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.
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;
FCopyGrace := True;
// 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;
WebCall('PM.toast(' + JsArg(ALabel + ' copied - clipboard cleared in ' +
CLIPBOARD_CLEAR_SECONDS.ToString + ' s') + ')');
// COPIER POUR COLLER AILLEURS : on rend la main a l'app d'ou l'on venait,
// il ne reste qu'a coller. Le retour dans Vault retrouve la liste telle
// quelle (delai de grace avant verrouillage).
if FUiBackAfterCopy then MoveAppToBack;
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.
// Le masquage est IMMEDIAT et sans condition - c'est lui qui protege.
TApplicationEvent.WillBecomeInactive:
if FScanning or (FWebView <> 'unlock') then
begin
StopScan; // la camera ne reste pas ouverte en arriere-plan
FWeb.Visible := False;
FLayWeb.Visible := False;
end;
// Le clair, lui, survit a un bref passage en arriere-plan.
//
// Verrouiller instantanement rendait le geste le plus courant penible :
// copier un mot de passe, basculer pour le coller, revenir - et devoir se
// reauthentifier, avec le code 2FA de nouveau derriere une invite. L'ecran
// etant deja masque, garder le clair quelques secondes de plus n'expose
// rien de visible ; c'est le temps d'un aller-retour, pas d'un oubli.
TApplicationEvent.EnteredBackground:
FBackgroundAt := Now;
// LE MASQUAGE NE DEMANDE RIEN, LA RESTITUTION EXIGEAIT UN COFFRE OUVERT.
//
// C'est toute l'affaire : plus haut, il suffit de ne pas etre sur l'accueil
// pour que la vue disparaisse - coffre ouvert ou non. Ici, elle ne revenait
// que si le coffre l'etait. Consulter les REGLAGES coffre ferme, puis
// laisser le telephone se verrouiller, cachait donc la page pour de bon :
// au retour il ne restait que le fond de la fenetre, un aplat bleu sans
// rien dessus et sans rien pour en sortir.
//
// La vue revient donc dans tous les cas - mais APRES le verrouillage
// eventuel, pour ne jamais montrer une liste qu'on vient d'effacer.
TApplicationEvent.BecameActive:
begin
if FVault.Count > 0 then
begin
if (FBackgroundAt > 0) and
(SecondsBetween(Now, FBackgroundAt) >=
GraceSeconds(FCopyGrace)) then
LockVault
else
// Retour a temps : on rend l'ecran quitte, pas un autre. La page a
// garde son etat, elle n'a ete que masquee.
Touch;
end;
// SAUF PENDANT UN SCAN : la fenetre d'autorisation de la camera fait
// passer l'app par ici APRES que le scan a demarre, et la page revenait
// par-dessus l'apercu - camera ouverte mais invisible au premier essai.
if not FScanning then
begin
FLayWeb.Visible := True;
FWeb.Visible := True;
end;
FBackgroundAt := 0;
FCopyGrace := False;
// RETOUR DANS VAULT = on vient chercher un mot de passe : la recherche
// est prete, texte precedent selectionne pour etre remplace.
if FUiKbdOnSearch and (FWebView = 'list') and (FPlain <> '') then
WebCall('PM.focusSearch()');
end;
end;
end;
{ ----------------------------------------------------------------------------
Journal
---------------------------------------------------------------------------- }
procedure TForm8.Log(const AMsg: string);
begin
// Appele depuis le thread de calcul : le moteur ne se pilote que depuis le
// thread principal.
TThread.Queue(nil,
procedure
begin
WebCall('PM.log(' + JsArg(AMsg) + ')');
end);
end;
procedure TForm8.Touch;
begin
FLastActivity := Now;
end;
procedure TForm8.OnIdleTimer(Sender: TObject);
begin
// Rien d'ouvert : rien a verrouiller.
//
// SUR FPlain, PAS SUR LE NOMBRE D'ENTREES. Un coffre vide en compte zero, et
// le minuteur se coupait donc de lui-meme : le coffre restait ouvert
// indefiniment. Vide aujourd'hui ne veut pas dire vide dans dix minutes.
if FPlain = '' then
begin
FIdleTimer.Enabled := False;
Exit;
end;
if MinutesBetween(Now, FLastActivity) >= AUTOLOCK_MINUTES then
begin
Log('Locked after ' + AUTOLOCK_MINUTES.ToString + ' min idle');
LockVault;
Exit;
end;
// LE MEME MINUTEUR, PAS UN SECOND. Il bat deja toutes les 15 s pour
// l'inactivite ; compter ses battements coute un entier, la ou un timer de
// plus coute un objet, un cycle de vie et une occasion de l'oublier a l'arret.
Inc(FTicksSinceProbe);
if FTicksSinceProbe >= PROBE_EVERY_TICKS then
begin
FTicksSinceProbe := 0;
ProbeRemote;
end;
end;
/// DEMANDER SI LE DEPOT A BOUGE, SANS RIEN ADOPTER.
///
/// Adopter de soi-meme pendant que quelqu'un lit une entree la ferait changer
/// sous ses yeux. On se contente donc de comparer les empreintes et d'allumer
/// un temoin : c'est l'utilisateur qui decide quand tirer.
///
/// LE CORPS EST TELECHARGE QUAND MEME - l'API des contenus de Gitea ne sait
/// pas repondre sans lui - mais il est jete sans etre dechiffre : pas de
/// derivation, pas d'ecriture, seulement une comparaison de chaines. Le prix
/// est en reseau, pas en temps ni en batterie.
/// RETIRER LE CODE DE DEVERROUILLAGE.
///
/// Il manquait : vider le champ voulait dire "rien tape", pas "enlever la
/// protection", et rien d'autre ne le proposait. On pouvait donc en poser un
/// et jamais en sortir.
///
/// EXIGE UN COFFRE OUVERT, et c'est la preuve qu'on cherche : le cache ne
/// s'est laisse lire que sous le bon code. Sans cette condition, n'importe qui
/// tenant l'appareil deverrouille pourrait retirer la protection sans la
/// connaitre.
/// L'ICONE DE L'ENTREE OUVERTE : la chercher, ou l'effacer.
///
/// LE SEUL APPEL DE CETTE APPLICATION QUI SORT AILLEURS QUE VERS LE DEPOT, et
/// il ne part que sur demande, entree par entree. Il dit a DuckDuckGo qu'on
/// s'interesse a ce domaine - c'est peu, mais ce n'est pas rien, et cela ne
/// doit pas se produire dans le dos de quelqu'un.
///
/// La recherche est hors du thread principal : cinq secondes d'attente
/// figeraient l'ecran. L'ecriture, elle, repasse par CommitChange - donc par
/// le meme chemin que tout le reste, avec sa publication et son hors-ligne.
/// LES ANCIENS MOTS DE PASSE DE L'ENTREE OUVERTE.
///
/// Ils ne descendent vers la page qu'ici, sur demande, et pour une seule
/// entree. La page les jette au verrouillage comme le reste du clair.
procedure TForm8.SetRemoteAhead(AOn: Boolean);
begin
FRemoteAhead := AOn;
// Appele depuis les threads de calcul comme depuis le principal : la file
// rend les deux cas identiques, et le moteur ne se pilote que d'ici.
TThread.Queue(nil,
procedure
begin
WebCall(Format('PM.setRemoteAhead(%s)', [LowerCase(BoolToStr(AOn, True))]));
end);
end;
procedure TForm8.ShowPasswordHistory;
var
LRows: TArray<string>;
LArr: TJSONArray;
LObj: TJSONObject;
LTab: Integer;
LLine: string;
begin
if FCurrent.Uuid = '' then Exit;
if FPlain = '' then
begin
WebCall('PM.toast("Open the vault again to read the history")');
Exit;
end;
LRows := PasswordHistory(FPlain, FCurrent.Uuid);
FHistory := LRows;
if Length(LRows) = 0 then
begin
// DIRE LAQUELLE DES DEUX. Une entree jamais modifiee n'a pas d'historique ;
// un instantane publie par un poste plus ancien n'en porte pour aucune. Les
// confondre ferait chercher une panne la ou il n'y a rien a trouver.
WebCall('PM.toast("No previous password recorded for this entry")');
Exit;
end;
LArr := TJSONArray.Create;
try
for LLine in LRows do
begin
LTab := Pos(#9, LLine);
LObj := TJSONObject.Create;
LObj.AddPair('at', Copy(LLine, 1, LTab - 1));
LObj.AddPair('pwd', Copy(LLine, LTab + 1, MaxInt));
LArr.AddElement(LObj);
end;
WebCall('PM.showHistory(' + JsArg(LArr.ToJSON) + ')');
finally
LArr.Free;
end;
end;
procedure TForm8.SetEntryIcon(AFetch: Boolean);
var
LUuid, LSite, LTitle: string;
begin
if FBusy then Exit;
if FCurrent.Uuid = '' then
begin
RefuseChange('This entry has no uuid');
Exit;
end;
LUuid := FCurrent.Uuid;
LTitle := FCurrent.Display;
LSite := FCurrent.Site;
if not AFetch then
begin
CommitChange('Icon removed: ' + LTitle, 'icon removed from phone', LUuid,
function (APlain: string): string
begin
Result := PatchEntryIcon(APlain, LUuid, '', False);
end);
Exit;
end;
if HostOf(LSite) = '' then
begin
RefuseChange('This entry has no web address to look up');
Exit;
end;
SetBusy(True);
TThread.CreateAnonymousThread(
procedure
var
LUri, LErr: string;
begin
LUri := '';
LErr := '';
try
LUri := FetchFaviconDataUri(LSite, LErr);
except
on E: Exception do LErr := E.ClassName + ': ' + E.Message;
end;
TThread.Queue(nil,
procedure
begin
SetBusy(False);
if LUri = '' then
begin
Log('icon: ' + LErr);
WebCall('PM.toast(' + JsArg('No icon - ' + LErr) + ')');
Exit;
end;
Log(Format('icon: %d chars for %s', [Length(LUri), HostOf(LSite)]));
// Provenance a FAUX : elle vient d'une recherche automatique, pas
// d'un choix. Le poste ne remplace jamais une icone choisie lors
// d'un rafraichissement, et ce drapeau est ce qui le lui dit.
CommitChange('Icon set: ' + LTitle, 'icon fetched from phone', LUuid,
function (APlain: string): string
begin
Result := PatchEntryIcon(APlain, LUuid, LUri, False);
end);
end);
end).Start;
end;
/// L'ICONE VENUE DE LA GALERIE. Provenance a VRAI, comme un televersement
/// depuis le poste : une icone choisie ne doit jamais etre remplacee par une
/// recherche automatique, et ce drapeau est ce qui le dit au poste.
const
ICON_MAX_PX = 128;
procedure TForm8.IconPicked(AImage: TBitmap);
var
LSmall: TBitmap;
LStream: TMemoryStream;
LB64: TBase64Encoding;
LUri, LTitle, LUuid: string;
LScale: Single;
begin
if (AImage = nil) or (AImage.Width = 0) or (AImage.Height = 0) then Exit;
if FCurrent.Uuid = '' then Exit;
LUuid := FCurrent.Uuid;
LTitle := FCurrent.Display;
if AImage.Width > AImage.Height then
LScale := ICON_MAX_PX / AImage.Width
else
LScale := ICON_MAX_PX / AImage.Height;
if LScale > 1 then LScale := 1;
LSmall := TBitmap.Create(Round(AImage.Width * LScale),
Round(AImage.Height * LScale));
try
LSmall.Canvas.BeginScene;
try
LSmall.Canvas.DrawBitmap(AImage, RectF(0, 0, AImage.Width, AImage.Height),
RectF(0, 0, LSmall.Width, LSmall.Height), 1, True);
finally
LSmall.Canvas.EndScene;
end;
LStream := TMemoryStream.Create;
try
LSmall.SaveToStream(LStream); // PNG
// Sans coupure de ligne : une URI data: coupee ne s'affiche pas.
LB64 := TBase64Encoding.Create(0);
try
LUri := 'data:image/png;base64,'
+ LB64.EncodeBytesToString(LStream.Memory, LStream.Size);
finally
LB64.Free;
end;
finally
LStream.Free;
end;
finally
LSmall.Free;
end;
Log(Format('icon: picked image, %d chars', [Length(LUri)]));
CommitChange('Icon set: ' + LTitle, 'icon picked on phone', LUuid,
function (APlain: string): string
begin
Result := PatchEntryIcon(APlain, LUuid, LUri, True);
end);
end;
procedure TForm8.BeginPickIcon;
begin
if FPickIcon = nil then
begin
FPickIcon := TTakePhotoFromLibraryAction.Create(Self);
FPickIcon.OnDidFinishTaking := IconPicked;
end;
FPickIcon.Execute;
end;
procedure TForm8.PickEntryIcon;
begin
if FBusy then Exit;
if FCurrent.Uuid = '' then
begin
RefuseChange('This entry has no uuid');
Exit;
end;
{$IFDEF ANDROID}
// Les deux noms : le premier est celui d'Android 13 et plus, le second celui
// d'avant. Un nom inconnu du systeme est simplement refuse, et le selecteur
// recent n'exige de toute facon rien - on ouvre donc dans tous les cas, et
// c'est Android qui refuse s'il doit refuser.
PermissionsService.RequestPermissions(
['android.permission.READ_MEDIA_IMAGES',
'android.permission.READ_EXTERNAL_STORAGE'],
procedure(const APermissions: TClassicStringDynArray;
const AGrantResults: TClassicPermissionStatusDynArray)
begin
BeginPickIcon;
end);
{$ELSE}
BeginPickIcon;
{$ENDIF}
end;
/// POSER OU CHANGER LE CODE, IMMEDIATEMENT ET SUR DEMANDE.
///
/// Le coffre doit etre ouvert : c'est la seule preuve que le code courant est
/// connu, et la seule facon de tenir le clair qu'il faut resceller. Sans cette
/// exigence, quiconque tenait le telephone deverrouille pouvait deposer un
/// code depuis les reglages - le proprietaire l'appliquait ensuite lui-meme en
/// ouvrant son coffre, et se retrouvait dehors.
procedure TForm8.SetUnlockCode(const ANew: string);
begin
if FBusy then Exit;
if ANew = '' then
begin
// Un champ vide ne demande rien : c'est "Remove" qui retire, et lui exige
// le code courant. Repondre par un retrait silencieux serait une porte
// derobee vers exactement ce qu'on vient de fermer.
WebCall('PM.toast("Type a code first")');
Exit;
end;
// Le secret du depot n'entre pas ici : le code scelle le CACHE, et un coffre
// ne sur ce telephone n'a pas encore de depot.
if FPlain = '' then
begin
WebCall('PM.toast("Open the vault first")');
Exit;
end;
try
// ARequireAuth a FAUX : les deux protections s'excluent, un cache scelle
// par un code porte VER_PIN et non VER_WRAP.
SaveVault(FPlain, FETag, CachePwd, False, False, ANew,
FKey, FKeySalt, FKeyIters);
if not VaultNeedsPin then
begin
Log('Unlock code not set: ' + LastStoreError);
WebCall('PM.toast("Could not set the unlock code")');
Exit;
end;
FPinSealed := ANew;
// Le champ de l'accueil est vide : il sert a OUVRIR, et le coffre l'est
// deja. Le laisser rempli rescellerait sous lui a la prochaine ecriture.
FPin := '';
Log('Unlock code set');
WebCall('PM.toast("Unlock code set")');
WebCall('PM.pinChanged()');
PushUnlockMode;
except
on E: Exception do
begin
Log('Unlock code not set: ' + E.ClassName + ' - ' + E.Message);
WebCall('PM.toast("Could not set the unlock code")');
end;
end;
end;
/// Dit a la page comment le cache est scelle. 'password' = scelle sous un code
/// egal au mot de passe du coffre - connu seulement une fois ouvert (FPinSealed).
procedure TForm8.PushUnlockMode;
var
LMode: string;
LCan: Boolean;
begin
if VaultNeedsPin then
begin
if (FPinSealed <> '') and (FPinSealed = CachePwd) then
LMode := 'password'
else
LMode := 'code';
end
else if VaultNeedsAuth then
LMode := 'device'
else
LMode := 'none';
LCan := BiometricAvailable;
Log(Format('Unlock mode: %s, screen lock usable: %s %s',
[LMode, BoolToStr(LCan, True), LastBiometricError]));
WebCall(Format('PM.setUnlockMode("%s", %s, %s)',
[LMode, LowerCase(BoolToStr(LCan, True)),
LowerCase(BoolToStr(HasLocalContainer, True))]));
end;
/// LE BON NOM POUR LE MOT DE PASSE QUI OUVRE CE COFFRE. Un coffre venu de la
/// synchro s'ouvre au mot de passe de synchro ; l'appeler "vault password"
/// envoyait chercher un mot de passe qui n'existe pas.
function TForm8.PwdName: string;
begin
if HasLocalContainer then Result := 'vault password' else Result := 'sync password';
end;
procedure TForm8.StartScan;
begin
if FScanning or FBusy then Exit;
{$IFDEF ANDROID}
PermissionsService.RequestPermissions(
[JStringToString(TJManifest_permission.JavaClass.CAMERA)],
procedure(const APermissions: TClassicStringDynArray;
const AGrantResults: TClassicPermissionStatusDynArray)
begin
if (Length(AGrantResults) = 1) and
(AGrantResults[0] = TPermissionStatus.Granted) then
BeginScan
else
WebCall('PM.toast("Camera not allowed - type the settings instead")');
end);
{$ELSE}
BeginScan;
{$ENDIF}
end;
/// L'apercu est FMX, pas web : la vue web est une vue native posee PAR-DESSUS
/// les controles FMX, il faut donc la masquer pendant le scan.
procedure TForm8.BeginScan;
var
LBg: TRectangle;
LBtn: TButton;
LLbl: TLabel;
begin
if FScanLay = nil then
begin
FScanLay := TLayout.Create(Self);
FScanLay.Parent := Self;
FScanLay.Align := TAlignLayout.Contents;
LBg := TRectangle.Create(FScanLay);
LBg.Parent := FScanLay;
LBg.Align := TAlignLayout.Contents;
LBg.Fill.Color := TAlphaColors.Black;
LBg.Stroke.Kind := TBrushKind.None;
LBg.HitTest := False;
LLbl := TLabel.Create(FScanLay);
LLbl.Parent := FScanLay;
LLbl.Align := TAlignLayout.Top;
LLbl.Height := 72;
LLbl.Margins.Top := 24;
LLbl.StyledSettings := [];
LLbl.TextSettings.FontColor := TAlphaColors.White;
LLbl.TextSettings.Font.Size := 16;
LLbl.TextSettings.HorzAlign := TTextAlign.Center;
LLbl.WordWrap := True;
FScanLbl := LLbl;
// AUCUNE IMAGE = CAMERA TENUE AILLEURS. Ouverte par l'appareil photo du
// systeme, meme en arriere-plan, elle ne nous est pas donnee - et sans ce
// guet l'ecran restait noir sans un mot.
FScanWatch := TTimer.Create(Self);
FScanWatch.Enabled := False;
FScanWatch.Interval := 3000;
FScanWatch.OnTimer := OnScanWatch;
LBtn := TButton.Create(FScanLay);
LBtn.Parent := FScanLay;
LBtn.Align := TAlignLayout.Bottom;
LBtn.Height := 56;
LBtn.Margins.Rect := TRectF.Create(24, 8, 24, 32);
LBtn.Text := 'Cancel';
LBtn.OnClick := DoCancelScan;
FScanImg := TImage.Create(FScanLay);
FScanImg.Parent := FScanLay;
FScanImg.Align := TAlignLayout.Client;
FScanImg.WrapMode := TImageWrapMode.Fit;
FScanImg.HitTest := False;
FCam := TCameraComponent.Create(Self);
FCam.OnSampleBufferReady := OnCamFrame;
end;
HideSoftKeyboard;
FScanning := True;
FScanBusy := False;
FScanFrame := 0;
FLayWeb.Visible := False;
FScanLay.Visible := True;
FScanLay.BringToFront;
FCam.Active := False;
FCam.Kind := TCameraKind.BackCamera;
FCam.Quality := TVideoCaptureQuality.MediumQuality;
try
FCam.FocusMode := TFocusMode.ContinuousAutoFocus;
except
// Pas d'autofocus continu : l'image restera nette a bonne distance.
end;
FScanLbl.Text := 'Point the camera at the QR shown on the PC';
FCam.Active := True;
FScanWatch.Enabled := True;
Log('QR scan started');
end;
procedure TForm8.StopScan;
begin
if not FScanning then Exit;
FScanning := False;
if FScanWatch <> nil then FScanWatch.Enabled := False;
if FCam <> nil then FCam.Active := False;
if FScanLay <> nil then FScanLay.Visible := False;
// LES DEUX COUCHES : la fenetre d'autorisation de la camera fait passer par
// WillBecomeInactive, qui masque aussi la vue web elle-meme - et BecameActive
// la laisse masquee pendant le scan. Ne rendre que le calque laissait l'ecran
// bleu du fond apres le premier scan.
FLayWeb.Visible := True;
FWeb.Visible := True;
end;
procedure TForm8.DoCancelScan(Sender: TObject);
begin
StopScan;
end;
procedure TForm8.OnScanWatch(Sender: TObject);
begin
FScanWatch.Enabled := False;
if FScanning and (FScanFrame = 0) then
begin
FScanLbl.Text := 'Camera busy - close the camera app, then Cancel and scan again';
Log('QR scan: no camera frame after 3 s');
end;
end;
/// Une image sur quatre part au decodage, jamais deux a la fois : ZXing prend
/// quelques dizaines de ms, et empiler les images figerait l'apercu.
procedure TForm8.OnCamFrame(Sender: TObject; const ATime: TMediaTime);
begin
TThread.Synchronize(nil,
procedure
var
LBmp: TBitmap;
begin
if not FScanning then Exit;
FCam.SampleBufferToBitmap(FScanImg.Bitmap, True);
Inc(FScanFrame);
if FScanBusy or (FScanFrame mod 4 <> 0) then Exit;
FScanBusy := True;
LBmp := TBitmap.Create;
LBmp.Assign(FScanImg.Bitmap);
TThread.CreateAnonymousThread(
procedure
var
LMgr: TScanManager;
LRes: TReadResult;
LText: string;
LHints: TDictionary<TDecodeHintType, TObject>;
begin
LText := '';
LRes := nil;
// TRY_HARDER : le chercheur de motifs balaie chaque ligne au lieu
// d'en sauter - indispensable pour un QR photographie sur un ecran.
LHints := TDictionary<TDecodeHintType, TObject>.Create;
LHints.Add(TDecodeHintType.TRY_HARDER, nil);
LMgr := TScanManager.Create(TBarcodeFormat.QR_CODE, LHints); // libere les indices
try
try
LRes := LMgr.Scan(LBmp);
if LRes <> nil then LText := LRes.Text;
except
LText := '';
end;
finally
LRes.Free;
LMgr.Free;
LBmp.Free;
end;
TThread.Queue(nil,
procedure
begin
FScanBusy := False;
if (not FScanning) or (LText = '') then Exit;
// CHERCHE, NE COMPARE PAS LE DEBUT : le texte decode est arrive
// avec un caractere invisible en tete (104 lus pour 103 emis),
// et le lien etait ignore alors qu'il etait lu.
if Pos('pmserver://sync?', LText) > 0 then
begin
StopScan;
ApplySyncLink(Trim(Copy(LText, Pos('pmserver://sync?', LText), MaxInt)));
end
else
Log('QR scan: not a sync link, first char code ' + IntToStr(Ord(LText[1])));
end);
end).Start;
end);
end;
/// pmserver://sync?u=URL&t=JETON -> champs des reglages remplis, RIEN
/// d'enregistre. Le lien peut venir de n'importe quelle page ou application :
/// c'est Save, geste de l'utilisateur devant l'URL affichee, qui valide.
function TForm8.ApplySyncLink(const ALink: string): Boolean;
var
LPair: string;
LUrl, LTok, LName, LValue: string;
LEq: Integer;
begin
Result := False;
if not StartsText('pmserver://sync?', ALink) then Exit;
LUrl := '';
LTok := '';
for LPair in Copy(ALink, Length('pmserver://sync?') + 1, MaxInt).Split(['&']) do
begin
LEq := Pos('=', LPair);
if LEq = 0 then Continue;
LName := Copy(LPair, 1, LEq - 1);
LValue := TNetEncoding.URL.Decode(Copy(LPair, LEq + 1, MaxInt));
if LName = 'u' then LUrl := LValue
else if LName = 't' then LTok := LValue;
end;
if (LUrl = '') or (LTok = '') then Exit;
Result := True;
Log('Sync settings received from a link: token ' + Fingerprint(LTok));
WebCall('openSettings()');
WebCall(Format('PM.pasteConfig(%s, %s)', [JsArg(LUrl), JsArg(LTok)]));
end;
{$IFDEF ANDROID}
procedure TForm8.OnActivityMessage(const Sender: TObject; const M: TMessage);
var
LIntent: JIntent;
begin
if not (M is TMessageReceivedNotification) then Exit;
LIntent := TMessageReceivedNotification(M).Value;
if (LIntent <> nil) and (LIntent.getDataString <> nil) then
ApplySyncLink(JStringToString(LIntent.getDataString));
end;
{$ENDIF}
function TForm8.CachePwd: string;
begin
if HasLocalContainer then Result := FVaultPwd else Result := FSyncPwd;
end;
/// RETIRER UNE PROTECTION DEMANDE DE LA CONNAITRE.
///
/// Le coffre ouvert ne suffit pas : il peut l'avoir ete il y a une heure et
/// rester a l'ecran. Quelqu'un qui trouve le telephone dans cet etat pouvait
/// lever le code en deux appuis, et rien ne le lui demandait. Retaper le code
/// courant ne coute rien a son proprietaire, et arrete l'autre.
procedure TForm8.ClearUnlockCode(const AConfirm: string);
begin
if FBusy then
begin
WebCall('PM.toast("Busy - wait for the current operation")');
Exit;
end;
if not VaultNeedsPin then
begin
WebCall('PM.toast("No unlock code to remove")');
Exit;
end;
// Le secret du depot n'entre pas ici : le code scelle le CACHE, et un coffre
// ne sur ce telephone n'a pas encore de depot.
if FPlain = '' then
begin
WebCall('PM.toast("Open the vault first")');
Exit;
end;
// Compare a ce que le cache est REELLEMENT scelle, pas a ce qui traine dans
// un champ : FPinSealed n'est pose qu'a une ouverture reussie.
if (FPinSealed = '') or (AConfirm <> FPinSealed) then
begin
WebCall('PM.toast("Type the current unlock code to remove it")');
Exit;
end;
try
// Cle NEUVE : le verrouillage d'ecran a pu changer pendant que le code
// protegeait, et une ancienne paire invalidee scellerait un fichier
// impossible a rouvrir.
SaveVault(FPlain, FETag, CachePwd, BiometricAvailable, True, '',
FKey, FKeySalt, FKeyIters, True);
if VaultNeedsPin then
begin
Log('Unlock code not removed: ' + LastStoreError);
WebCall('PM.toast("Could not remove the unlock code")');
Exit;
end;
FPinSealed := '';
FPin := '';
Log('Unlock code removed');
WebCall('PM.toast("Unlock code removed")');
WebCall('PM.pinChanged()');
PushUnlockMode;
ShowUnlock;
except
on E: Exception do
begin
Log('Unlock code not removed: ' + E.ClassName + ' - ' + E.Message);
WebCall('PM.toast("Could not remove the unlock code")');
end;
end;
end;
procedure TForm8.ProbeRemote;
begin
if FBusy or (FUrl = '') or (FToken = '') then Exit;
// Un coffre ne ici n'a pas de depot a interroger.
if HasLocalContainer then Exit;
if FETag = '' then Exit;
TThread.CreateAnonymousThread(
procedure
var
LClient: TSyncClient;
LGet: TSyncResult;
LAhead: Boolean;
begin
LAhead := False;
LClient := TSyncClient.Create(FUrl, FToken);
try
try
LGet := LClient.Fetch(FETag);
LAhead := (LGet.Status = ssOK) and (LGet.ETag <> '')
and not SameText(LGet.ETag.Trim, FETag.Trim);
except
// Hors reseau : ce n'est pas une nouvelle du depot, c'est une absence
// de nouvelle. Le temoin ne change pas.
Exit;
end;
finally
LClient.Free;
end;
if not LAhead then Exit;
TThread.Queue(nil,
procedure
begin
if FRemoteAhead then Exit; // deja dit
Log('remote has moved - sync to bring it in');
SetRemoteAhead(True);
end);
end).Start;
end;
procedure TForm8.Status(const AMsg: string);
begin
WebCall('PM.setStatus(' + JsArg(AMsg) + ')');
end;
/// Le meme endroit, mais en rouge : ce qui suit est un REFUS, pas un etat.
///
/// Deux procedures plutot qu'un drapeau devine du texte : trier des messages
/// sur leur contenu est exactement ce qui a deja detruit un cache dans ce
/// projet. C'est l'appelant qui sait s'il refuse.
procedure TForm8.StatusErr(const AMsg: string);
begin
WebCall('PM.setStatus(' + JsArg(AMsg) + ', true)');
end;
/// UNE ERREUR DE REGLAGE S'AFFICHE LA OU ON LA CORRIGE : les reglages s'ouvrent
/// et le message y est en rouge, au-dessus des champs du depot.
procedure TForm8.ShowSettingsError(const AMsg: string);
begin
StatusErr(AMsg);
WebCall('openSettings()');
WebCall('PM.settingsError(' + JsArg(AMsg) + ')');
end;
procedure TForm8.SetBusy(ABusy: Boolean);
var
LCanOpen: Boolean;
LLabel: string;
begin
FBusy := ABusy;
FDeadline.Enabled := False; // reposee a zero, pas prolongee
FDeadline.Enabled := ABusy;
// Les boutons de l'accueil palissaient deja, mais depuis la liste rien ne
// disait qu'on travaillait : le voile vaut pour tous les ecrans.
WebCall('PM.setBusy(' + LowerCase(BoolToStr(ABusy, True)) + ')');
LCanOpen := HasVault and not FVaultUnreadable;
// L'intitule suit l'etat du cache et non un mot fixe : sans coffre local,
// l'action n'est pas une synchronisation mais un premier telechargement, et
// le reprendre en dur ici effacait cette distinction a chaque passage.
if LCanOpen then LLabel := 'Sync' else LLabel := 'Download vault';
WebCall(Format('PM.setActions(%s, %s, %s)',
[LowerCase(BoolToStr(LCanOpen, True)), JsArg(LLabel),
LowerCase(BoolToStr(ABusy, True))]));
end;
/// L'operation reseau n'a pas rendu la main dans le delai. On rend l'interface
/// a l'utilisateur et on le dit. Le thread, lui, est ABANDONNE : il mourra
/// quand sa socket finira par echouer, et s'il aboutit malgre tout, son
/// resultat s'affichera - il n'y a rien a annuler.
procedure TForm8.OnDeadline(Sender: TObject);
begin
FDeadline.Enabled := False;
if not FBusy then Exit;
Log(' no reply after ' + (FDeadline.Interval div 1000).ToString +
' s - request abandoned');
Status('No reply from the server');
SetBusy(False);
end;
end.
Reference in New Issue View Git Blame Copy Permalink