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. } interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Diagnostics, System.Rtti, System.NetEncoding, System.DateUtils, System.Generics.Collections, System.IOUtils, 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, 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. {$IF DEFINED(ANDROID)} FIRSTRUN_URL = 'https://git.ai-agents4you.com/api/v1/repos/Zaki/pm_sync/contents/vault-sync.json'; {$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; // 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; // FIRSTRUN_TOKEN et TEST_PWD viennent d'un fichier LOCAL, hors depot : le // jeton authentifie l'appareil, le mot de passe ouvre le coffre entier. Ni // l'un ni l'autre n'a sa place dans un depot, meme sans remote. Absents apres // un clone -> recopier PMA.LocalConfig.template.inc. {$I android-client\PMA.LocalConfig.inc} type 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; // 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; /// 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; // --- 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; /// 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; 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 WriteTest; {$ENDIF} procedure OpenEntry(AVaultIndex: Integer); 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 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, System.JSON; {$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); PushConfig; ShowUnlock; {$IFDEF DEBUG} WebCall('PM.setDebug(true)'); // 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. LCanOpen := HasVault and not FVaultUnreadable; if LCanOpen then begin if VaultNeedsAuth then Status('Vault on this device - protected') else Status('Vault on this device'); WebCall('PM.setActions(true, "Sync", false)'); end else begin Status('No local vault - first download'); 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 not FLayWeb.Visible then Exit; // 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). 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, ''); end; procedure TForm8.OnWebLoaded(ASender: TObject); var LCall: string; begin FWebReady := True; for LCall in FWebPending do FWeb.EvaluateJavaScript(LCall); SetLength(FWebPending, 0); end; /// 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// // 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'); except on E: Exception do Log('selfcheck FAILED: ' + E.ClassName + ' - ' + E.Message); end; end; /// Essai du chemin d'ecriture, VERS UN AUTRE FICHIER que le coffre. /// /// Le premier PUT est le moment ou une erreur de transport se paie en donnees /// perdues : un corps mal forme, un sha mal place, et vault-sync.json est /// remplace par quelque chose que personne ne sait relire. L'ecrire d'abord /// sous un autre nom prouve exactement les memes choses - enveloppe, jeton, /// droits, sha rendu - sans mettre le coffre en jeu une seule fois. procedure TForm8.WriteTest; var LUrl: string; begin if FBusy then Exit; SetBusy(True); // Meme depot, autre fichier : on remplace le dernier segment du chemin. LUrl := FUrl.Substring(0, FUrl.LastIndexOf('/') + 1) + 'write-test.json'; TThread.CreateAnonymousThread( procedure var LClient: TSyncClient; LRes: TSyncResult; LBody: string; begin LClient := TSyncClient.Create(LUrl, FToken); try LBody := EncryptContainer( Format('{"probe":"write path","at":"%s"}', [FormatDateTime('yyyy-mm-dd"T"hh:nn:ss"Z"', TTimeZone.Local.ToUniversalTime(Now))]), FSyncPwd, 1000); Log('PUT ' + LUrl); Log(' token ' + IntToStr(Length(FToken)) + ' chars, body ' + IntToStr(Length(LBody)) + ' chars'); // Sha vide : on cree le fichier, ou on echoue en 409 s'il existe deja - // ce qui prouverait le controle de concurrence aussi surement. LRes := LClient.Put(LBody, '', 'write path probe from phone'); case LRes.Status of ssOK: Log(' OK ' + LRes.HttpCode.ToString + ' - new sha ' + LRes.ETag); ssConflict: Log(' 409 - file already there, concurrency control works'); else Log(' failed: ' + LRes.HttpCode.ToString + ' ' + LRes.Error); end; finally LClient.Free; TThread.Queue(nil, procedure begin SetBusy(False); end); end; end).Start; end; /// Descend les coordonnees du serveur dans les champs de la page. procedure TForm8.PushConfig; var LUrl, LToken: string; begin FUrl := FIRSTRUN_URL; FToken := FIRSTRUN_TOKEN; FPwd := TEST_PWD; // 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; 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. if AUrl.StartsWith('cmd://') then HandleWebCommand(AUrl.Substring(6)); 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 FWebView := Param('view') 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; FPwd := TNetEncoding.URL.Decode(Param('p')); end else if LAction = 'openvault' then DoOpenLocal(nil) else if LAction = 'sync' then DoSync(nil) {$IFDEF DEBUG} else if LAction = 'writetest' then WriteTest {$ENDIF} 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 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); PushConfig; ShowUnlock; end; procedure TForm8.AdoptVault(const APlainJson: string); begin FVault.LoadFromJson(APlainJson); Log(' ' + FVault.LiveCount.ToString + ' entries, ' + FVault.TrashCount.ToString + ' in trash'); FVaultUnreadable := False; 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; procedure TForm8.OpenLocalNow; var LPlain, LETag, LPwd: string; LSw: TStopwatch; begin // 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; if LoadVault(LPlain, LETag, LPwd) then begin 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 FSyncPwd := LPwd; // 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 not VaultNeedsAuth then Log('Plain cache; device authentication available: ' + BoolToStr(BiometricAvailable, True) + ' ' + LastBiometricError); if (not VaultNeedsAuth) 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); 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; try LSw := TStopwatch.StartNew; AdoptVault(LPlain); 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. 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; PushConfig; 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. FVaultUnreadable := True; PushConfig; ShowUnlock; Log('Local vault unreadable: ' + LastStoreError); Status('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; // 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); PushConfig; 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 LPwd = '' then begin Status('Sync password required'); Exit; end; WebCall('PM.clearLog()'); // 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. if VaultNeedsAuth and (FVault.Count = 0) 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) 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; 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. 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'); 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 TThread.Queue(nil, procedure begin Status('Nothing to download (404)'); end); Exit; end; ssRefused, ssHttpError, ssNetworkError: begin // En fond, un echec reseau ne se signale pas : le coffre local // est affiche, hors ligne est un etat normal, et une alerte ici // apprendrait a l'utilisateur a ignorer les alertes. Log(' failed: ' + LRes.Error); if not ASilent then TThread.Queue(nil, procedure begin Status('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 := DecryptContainer(LRes.Container, APwd); LSw.Stop; FETag := LRes.ETag; Log(' decrypted in ' + LSw.ElapsedMilliseconds.ToString + ' ms'); // Ecrit APRES un dechiffrement reussi seulement, et avec son ETag : // les deux doivent rester coherents. try // Le mot de passe part avec le coffre : c'est lui qui permettra au // prochain lancement de rafraichir sans rien demander. SaveVault(LPlain, FETag, APwd, LCanAuth); 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 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. if not ASilent then TThread.Queue(nil, procedure begin Status('Failed - wrong sync password?'); 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; // 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') + ')'); 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 FWebView <> 'unlock' then begin 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; TApplicationEvent.BecameActive: if FVault.Count > 0 then begin if (FBackgroundAt > 0) and (SecondsBetween(Now, FBackgroundAt) >= BACKGROUND_GRACE_SECONDS) then LockVault else begin // Retour a temps : on rend l'ecran quitte, pas un autre. La page a // garde son etat, elle n'a ete que masquee. FLayWeb.Visible := True; FWeb.Visible := True; Touch; end; FBackgroundAt := 0; 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. if FVault.Count = 0 then begin FIdleTimer.Enabled := False; Exit; end; if MinutesBetween(Now, FLastActivity) >= AUTOLOCK_MINUTES then begin Log('Locked after ' + AUTOLOCK_MINUTES.ToString + ' min idle'); LockVault; end; end; procedure TForm8.Status(const AMsg: string); begin WebCall('PM.setStatus(' + 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; 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.