r-zakarya
4d9fd2c34a
The except only covered decryption and the patch. An exception from re-encryption or from the PUT skipped the block that restores the screen - and that block also held the message, so the failure was invisible as well as permanent: the row stayed on "Saving..." with nothing to explain it. Restoring the screen now lives in the finally, so it happens whatever the code above did. A catch-all around the body turns any unforeseen exception into a message and a log line, because a failure that says nothing is indistinguishable from slowness - which is exactly how this one was reported. Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
1530 lines
57 KiB
ObjectPascal
1530 lines
57 KiB
ObjectPascal
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, 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,
|
|
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<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;
|
|
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 WriteTest;
|
|
{$ENDIF}
|
|
procedure OpenEntry(AVaultIndex: Integer);
|
|
procedure SaveEntryPassword(const ANewValue: string);
|
|
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 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, 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;
|
|
|
|
/// 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;
|
|
/// 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;
|
|
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.
|
|
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.
|
|
procedure TForm8.SaveEntryPassword(const ANewValue: string);
|
|
var
|
|
LUuid, LTitle: string;
|
|
begin
|
|
if FBusy then Exit;
|
|
if FCurrent.Uuid = '' then
|
|
begin
|
|
WebCall('PM.toast("This entry has no uuid - cannot be updated")');
|
|
Exit;
|
|
end;
|
|
if FSyncPwd = '' then
|
|
begin
|
|
WebCall('PM.toast("Sync password missing - open the vault first")');
|
|
Exit;
|
|
end;
|
|
LUuid := FCurrent.Uuid;
|
|
LTitle := FCurrent.Display;
|
|
SetBusy(True);
|
|
|
|
TThread.CreateAnonymousThread(
|
|
procedure
|
|
var
|
|
LClient: TSyncClient;
|
|
LGet, LPut: TSyncResult;
|
|
LPlain, LNew, LBody, LErr: string;
|
|
LKey, LSalt: TBytes;
|
|
LIter, LAttempt: Integer;
|
|
LSw: TStopwatch;
|
|
LDone: Boolean;
|
|
begin
|
|
LClient := TSyncClient.Create(FUrl, FToken);
|
|
LDone := False;
|
|
LErr := '';
|
|
try
|
|
try
|
|
for LAttempt := 1 to 3 do
|
|
begin
|
|
Log(Format('save: attempt %d - GET', [LAttempt]));
|
|
// Sans empreinte connue : on VEUT le corps, pas un 304.
|
|
LGet := LClient.Fetch;
|
|
if LGet.Status <> ssOK then
|
|
begin
|
|
LErr := Format('read failed (HTTP %d) %s', [LGet.HttpCode, LGet.Error]);
|
|
Break;
|
|
end;
|
|
|
|
try
|
|
LPlain := DecryptContainer(LGet.Container, FSyncPwd);
|
|
LNew := PatchEntryField(LPlain, LUuid, 'password', ANewValue);
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
LErr := E.Message;
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
LSw := TStopwatch.StartNew;
|
|
LBody := EncryptContainerWithKey(LNew, LKey, LSalt, LIter);
|
|
Log(Format('save: re-encrypt in %d ms', [LSw.ElapsedMilliseconds]));
|
|
LPut := LClient.Put(LBody, LGet.ETag, 'password change from phone');
|
|
if LPut.Status = ssOK then
|
|
begin
|
|
Log('save: published, new sha ' + LPut.ETag);
|
|
// Le cache local suit le distant, avec SON empreinte : les laisser
|
|
// diverger ferait retelecharger et redechiffrer a la prochaine
|
|
// ouverture pour retrouver ce qu'on vient d'ecrire.
|
|
FETag := LPut.ETag;
|
|
try
|
|
SaveVault(LNew, FETag, FSyncPwd, BiometricAvailable);
|
|
except
|
|
on E: Exception do Log(' cache not written: ' + E.Message);
|
|
end;
|
|
LDone := True;
|
|
Break;
|
|
end;
|
|
|
|
if LPut.Status = ssConflict then
|
|
begin
|
|
Log('save: 409 - another device published, re-reading');
|
|
Continue;
|
|
end;
|
|
|
|
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';
|
|
|
|
TThread.Queue(nil,
|
|
procedure
|
|
begin
|
|
if LDone then
|
|
begin
|
|
AdoptVault(LNew);
|
|
WebCall('PM.toast(' + JsArg('Saved: ' + LTitle) + ')');
|
|
end
|
|
else
|
|
WebCall('PM.toast(' + JsArg('Not saved - ' + LErr) + ')');
|
|
end);
|
|
except
|
|
// FILET. Le rechiffrement et le PUT sont hors du try qui
|
|
// couvre le dechiffrement : une exception y sortait sans un mot,
|
|
// et l'echec devenait indiscernable d'une lenteur.
|
|
on E: Exception do
|
|
begin
|
|
LErr := E.ClassName + ': ' + E.Message;
|
|
Log('save FAILED: ' + LErr);
|
|
TThread.Queue(nil, procedure
|
|
begin WebCall('PM.toast(' + JsArg('Not saved - ' + LErr) + ')'); end);
|
|
end;
|
|
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.
|
|
// Quoi qu'il arrive au-dessus, l'ecran redevient utilisable.
|
|
TThread.Queue(nil,
|
|
procedure
|
|
begin
|
|
SetBusy(False);
|
|
ReopenEntryByUuid(LUuid);
|
|
end);
|
|
end;
|
|
end).Start;
|
|
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, LGet: TSyncResult;
|
|
LBody, LSha: 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);
|
|
// LIRE D'ABORD, ECRIRE ENSUITE - la sequence reelle. Un sha vide veut
|
|
// dire « cree », et Gitea refuse alors en 422 si le fichier est deja
|
|
// la ; c'est le cas de mise a jour qui compte, et il exige le sha
|
|
// courant. Un 404 au GET signifie simplement qu'il n'existe pas
|
|
// encore : on cree, sha vide.
|
|
LGet := LClient.Fetch;
|
|
if LGet.Status = ssOK then
|
|
LSha := LGet.ETag
|
|
else
|
|
LSha := '';
|
|
Log(Format('GET first: HTTP %d, sha %s', [LGet.HttpCode,
|
|
IfThen(LSha = '', '(aucun - creation)', LSha)]));
|
|
|
|
Log('PUT ' + LUrl);
|
|
Log(Format(' token %s (%d chars), body %d chars',
|
|
[Fingerprint(FToken), Length(FToken), Length(LBody)]));
|
|
LRes := LClient.Put(LBody, LSha, '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;
|
|
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);
|
|
HandleWebCommand(AUrl.Substring(6));
|
|
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
|
|
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'));
|
|
// 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)
|
|
|
|
// 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 = 'setpwd' then
|
|
SaveEntryPassword(TNetEncoding.URL.Decode(Param('v')))
|
|
{$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);
|
|
// 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.
|
|
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;
|
|
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;
|
|
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);
|
|
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');
|
|
|
|
// 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
|
|
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.
|