From 8c1cabb5bd6179a37fe15d52b132eb58da2705e9 Mon Sep 17 00:00:00 2001 From: r-zakarya <82443831+r-zakarya@users.noreply.github.com> Date: Sun, 16 Aug 2026 23:57:46 +0100 Subject: [PATCH] feat(android): the list and the detail move to HTML The FMX controls lost this one on merit. Every screen re-taught the same lessons: a template missing from the loaded style, an alignment order left to chance, a HitTest swallowing a tap, a native view painting over everything. The engine draws the same interface in forty lines of CSS and shapes Arabic on its own. The bridge needs no local server, so no port is open on the device: evaluateJavascript carries the data down, an intercepted cmd:// navigation carries the actions up. Through a throwaway iframe - FMX always tells the engine it did not handle the navigation, which on an unknown scheme replaces the page with an error screen. Secrets do not travel over that bridge. The list gets names, sites and usernames, which are already on screen; copying from a row sends an index and Delphi reads the vault itself. Only the open entry has its values in the JS heap, and PM.wipe clears them on lock. Folders become a row of chips with counts instead of a full-screen panel: one tap, and the count says what to expect. Also gone: about eight hundred lines of the screen this replaces. Co-Authored-By: Claude Opus 5 --- .gitignore | 1 + android-client/PMA.WebUI.pas | 243 +++++++ android-client/build-apk.ps1 | 59 ++ android-client/web/app.html | 396 ++++++++++++ android-client/web/web.rc | 1 + mainApk.pas | 1156 +++++++--------------------------- pmserverApk.dpr | 3 +- 7 files changed, 914 insertions(+), 945 deletions(-) create mode 100644 android-client/PMA.WebUI.pas create mode 100644 android-client/build-apk.ps1 create mode 100644 android-client/web/app.html create mode 100644 android-client/web/web.rc diff --git a/.gitignore b/.gitignore index 1d63e64..ba033b5 100644 --- a/.gitignore +++ b/.gitignore @@ -88,3 +88,4 @@ android-client/PMA.LocalConfig.inc # Genere depuis theme.rc + pm-dark.style, tous deux suivis (voir README). android-client/theme/theme.RES android-client/theme/theme.res +android-client/web/*.res diff --git a/android-client/PMA.WebUI.pas b/android-client/PMA.WebUI.pas new file mode 100644 index 0000000..7345544 --- /dev/null +++ b/android-client/PMA.WebUI.pas @@ -0,0 +1,243 @@ +unit PMA.WebUI; +{ + La page HTML et les donnees qu'on lui envoie. + + POURQUOI HTML. Les controles FMX n'ont pas de gabarit fiable sur mobile : + la journee a vu disparaitre tour a tour la ligne de liste, l'invite de + recherche, la ligne de detail, selon le style charge. Le reste - arrondis, + ordre d'alignement, HitTest qui avale un appui, vues natives qui se peignent + par-dessus - se re-decouvre a chaque ecran. Le moteur du systeme rend la + meme interface en quelques lignes de CSS, gere l'arabe et le bidirectionnel + seul, et c'est deja le langage de l'interface du poste Windows. + + CE QUI RESTE EN DELPHI : Keystore, biometrie, presse-papiers sensible, + FLAG_SECURE, reseau et dechiffrement. Le moteur n'est qu'une surface + d'affichage - il ne detient jamais de quoi ouvrir le coffre. + + CE QUI PART VERS LA PAGE. La liste porte les noms, sites et identifiants, + soit ce qui est deja a l'ecran, et AUCUN mot de passe : copier depuis une + ligne envoie un indice, Delphi copie depuis le coffre. Seule l'entree + ouverte a ses valeurs dans le tas JS, une a la fois. +} + +interface + +uses + PMA.Vault; + +/// La page, telle qu'embarquee dans le .res. ASCII pur - voir l'en-tete de +/// app.html : le chemin de chargement de FMX ne transporte pas l'encodage. +function PageHtml: string; + +/// Ce que la liste affiche et cherche. Les indices sont ceux du coffre, pas +/// ceux de la liste : la page filtre et trie sans rien redemander, donc les +/// deux ne coincident plus des la premiere frappe. +function VaultToJson(AVault: TVault): string; + +/// Les lignes d'une entree, dans l'ordre d'affichage. +function DetailToJson(const AEntry: TVaultEntry): string; + +/// Une ligne du detail par son rang, dans le MEME ordre que DetailToJson : la +/// page renvoie un rang, jamais une valeur, et Delphi relit le clair chez lui. +/// Faux si le rang ne designe rien. +function DetailRowAt(const AEntry: TVaultEntry; AIndex: Integer; + out ACaption, AValue: string): Boolean; + +implementation + +uses + // System.Types pour RT_RCDATA, que Winapi.Windows fournirait sur un poste. + System.SysUtils, System.Classes, System.Types, System.JSON, System.Character; + +{$R 'web\web.res' 'web\web.rc'} + +function PageHtml: string; +var + LStream: TResourceStream; + LBytes: TBytes; +begin + LStream := TResourceStream.Create(HInstance, 'PMAPP', RT_RCDATA); + try + SetLength(LBytes, LStream.Size); + LStream.ReadBuffer(LBytes, LStream.Size); + Result := TEncoding.UTF8.GetString(LBytes); + finally + LStream.Free; + end; +end; + +function HumanSize(ABytes: Int64): string; +begin + if ABytes >= 1024 * 1024 then + Result := Format('%.1f MB', [ABytes / (1024 * 1024)]) + else if ABytes >= 1024 then + Result := Format('%.0f KB', [ABytes / 1024]) + else + Result := Format('%d B', [ABytes]); +end; + +/// Premiere lettre du nom affiche, pour la pastille sans icone. +function Initial(const AName: string): string; +var + LCh: Char; +begin + Result := '?'; + for LCh in AName do + if LCh.IsLetterOrDigit then Exit(LCh.ToUpper); +end; + +function VaultToJson(AVault: TVault): string; +var + LRoot: TJSONObject; + LEntries, LFolders: TJSONArray; + LObj: TJSONObject; + LIdx: TArray; + I: Integer; + E: TVaultEntry; + LFolder: string; +begin + LRoot := TJSONObject.Create; + try + LEntries := TJSONArray.Create; + LRoot.AddPair('entries', LEntries); + + // Search('') rend les vivantes, deja triees par nom affiche. La page + // conserve cet ordre : trier de nouveau en JS demanderait de repliquer + // la meme convention de comparaison pour rien. + LIdx := AVault.Search(''); + for I := 0 to High(LIdx) do + begin + E := AVault.Entry(LIdx[I]); + LObj := TJSONObject.Create; + LObj.AddPair('i', TJSONNumber.Create(LIdx[I])); + LObj.AddPair('name', E.Display); + // Le site s'il existe, sinon l'identifiant : deux fois la meme chaine + // sur deux lignes n'apprendrait rien. + if E.Site <> '' then LObj.AddPair('sub', E.Site) + else if E.Username <> E.Display then LObj.AddPair('sub', E.Username) + else LObj.AddPair('sub', ''); + LObj.AddPair('folder', E.Folder); + // Corpus de recherche pre-assemble et en minuscules : la page cherche a + // chaque frappe, autant ne pas recomposer la meme chaine a chaque fois. + // Il couvre ce que couvrait TVault.Search - nom, site, identifiant, + // etiquettes - donc l'identifiant reste trouvable meme quand la ligne + // affiche le site. + LObj.AddPair('s', (E.Title + ' ' + E.Site + ' ' + E.Username + ' ' + + E.Tags).ToLower); + LObj.AddPair('icon', E.IconB64); + LObj.AddPair('initial', Initial(E.Display)); + LObj.AddPair('hasUser', TJSONBool.Create(E.Username <> '')); + LObj.AddPair('isNote', TJSONBool.Create(E.IsNote)); + LEntries.AddElement(LObj); + end; + + LFolders := TJSONArray.Create; + LRoot.AddPair('folders', LFolders); + for LFolder in AVault.Folders do + LFolders.Add(LFolder); + + Result := LRoot.ToJSON; + finally + LRoot.Free; + end; +end; + +/// Les lignes d'une entree. UN SEUL ENDROIT decide de leur composition et de +/// leur ordre : DetailToJson et DetailValues en dependent tous les deux, et +/// un ecart entre eux ferait copier la valeur de la ligne voisine. +type + TDetailRow = record + Caption, Value: string; + Secret: Boolean; + end; + +function BuildRows(const E: TVaultEntry): TArray; +var + LRows: TArray; + I: Integer; + LMeta: string; + + procedure Add(const ACaption, AValue: string; ASecret: Boolean); + begin + if AValue = '' then Exit; // une ligne vide n'apprend rien + SetLength(LRows, Length(LRows) + 1); + LRows[High(LRows)].Caption := ACaption; + LRows[High(LRows)].Value := AValue; + LRows[High(LRows)].Secret := ASecret; + end; + +begin + Add('Site', E.Site, False); + Add('Username', E.Username, False); + // Le corps d'une note est range dans le champ mot de passe : meme donnee, + // autre intitule, et pas de raison de la masquer comme un secret. + if E.IsNote then Add('Content', E.Password, False) + else Add('Password', E.Password, True); + + for I := 0 to High(E.Fields) do + Add(E.Fields[I].Caption, E.Fields[I].Value, E.Fields[I].Secret); + + // Les pieces jointes ne sont pas encore enregistrables sur le telephone, + // mais taire leur existence serait pire : on saurait sur le poste qu'une + // entree porte un document, et pas ici. + for I := 0 to High(E.Attachments) do + Add('Attachment - ' + HumanSize(E.Attachments[I].SizeBytes), + E.Attachments[I].FileName, False); + + LMeta := E.Folder; + if E.Tags <> '' then + begin + if LMeta <> '' then LMeta := LMeta + ' - '; + LMeta := LMeta + E.Tags; + end; + Add('Folder / tags', LMeta, False); + Add('Type', E.Template, False); + // Horodatage tel quel : de l'ISO 8601 UTC, lisible, et le reformater + // demanderait de decider d'un fuseau alors qu'il n'y a rien a arbitrer. + Add('Updated', E.UpdatedAt, False); + + Result := LRows; +end; + +function DetailToJson(const AEntry: TVaultEntry): string; +var + LRoot: TJSONObject; + LArr: TJSONArray; + LObj: TJSONObject; + LRows: TArray; + I: Integer; +begin + LRows := BuildRows(AEntry); + LRoot := TJSONObject.Create; + try + LRoot.AddPair('title', AEntry.Display); + LRoot.AddPair('totp', TJSONBool.Create(AEntry.Totp <> '')); + LArr := TJSONArray.Create; + LRoot.AddPair('rows', LArr); + for I := 0 to High(LRows) do + begin + LObj := TJSONObject.Create; + LObj.AddPair('c', LRows[I].Caption); + LObj.AddPair('v', LRows[I].Value); + LObj.AddPair('s', TJSONBool.Create(LRows[I].Secret)); + LArr.AddElement(LObj); + end; + Result := LRoot.ToJSON; + finally + LRoot.Free; + end; +end; + +function DetailRowAt(const AEntry: TVaultEntry; AIndex: Integer; + out ACaption, AValue: string): Boolean; +var + LRows: TArray; +begin + LRows := BuildRows(AEntry); + Result := (AIndex >= 0) and (AIndex <= High(LRows)); + if not Result then Exit; + ACaption := LRows[AIndex].Caption; + AValue := LRows[AIndex].Value; +end; + +end. diff --git a/android-client/build-apk.ps1 b/android-client/build-apk.ps1 new file mode 100644 index 0000000..10167d6 --- /dev/null +++ b/android-client/build-apk.ps1 @@ -0,0 +1,59 @@ +# Compile, empaquette, installe et lance le client Android. +# +# POURQUOI CE SCRIPT. La chaine a quatre etapes qui ne s'appellent pas entre +# elles, et en sauter une donne un APK qui s'installe sans porter la +# modification - le symptome se lit alors comme un bug applicatif. La premiere, +# web.res, s'est deja fait oublier une fois : la page embarquee etait celle +# d'avant l'edition, et le pont echouait pour une raison qui n'existait plus. +# +# -NoInstall compile et empaquette sans toucher au telephone. + +param([switch]$NoInstall) + +$ErrorActionPreference = 'Stop' +$root = Split-Path $PSScriptRoot -Parent +$bin = 'C:\Program Files (x86)\Embarcadero\Studio\23.0\bin' +$sdk = 'C:\Users\Public\Documents\Embarcadero\Studio\23.0\CatalogRepository' +$adb = "$sdk\AndroidSDK-2525-23.0.51511.6924\platform-tools\Adb.exe" +$strip = "$sdk\AndroidNDK-21-23.0.51511.6924\android-ndk-r21\toolchains\" + + 'aarch64-linux-android-4.9\prebuilt\windows-x86_64\aarch64-linux-android\bin\strip.exe' +$out = "$root\Android64\Debug" +$stage = "$out\pmserverApk" + +# 1. La page HTML -> ressource liee dans l'executable. +Push-Location "$PSScriptRoot\web" +& "$bin\brcc32.exe" web.rc -foweb.res | Out-Null +Pop-Location + +# 2. Compilation Delphi. +$msbuild = "`"$bin\rsvars.bat`" && msbuild `"$root\pmserverApk.dproj`"" +$log = cmd /c "$msbuild /p:Platform=Android64 /p:Config=Debug /t:Build /v:minimal /nologo" 2>&1 +$err = $log | Select-String -Pattern 'error' +if ($err) { $err | ForEach-Object { $_.Line }; throw 'compilation echouee' } +$log | Select-String -Pattern 'lines,' | ForEach-Object { $_.Line.Trim() } + +# 3. Mise en place a la main de ce que le deploiement ne place pas : manifeste, +# .dex, et la bibliotheque native ALLEGEE - la version de debogage pese +# 91 Mo, plus que la place libre sur ce volume. +Copy-Item "$out\AndroidManifest.xml" "$stage\AndroidManifest.xml" -Force +Copy-Item "$out\pmserverApk.classes\*.dex" "$stage\classes\" -Force +& $strip --strip-debug -o "$stage\library\lib\arm64-v8a\libpmserverApk.so" "$out\libpmserverApk.so" + +cmd /c "$msbuild /p:Platform=Android64 /p:Config=Debug /t:Deploy /v:minimal /nologo" 2>&1 | + Select-String -Pattern 'error' | ForEach-Object { $_.Line } + +# 4. aapt + zipalign + apksigner, et remise en place de ce que Deploy efface. +& "$PSScriptRoot\repack-apk.ps1" | Select-Object -Last 1 + +if ($NoInstall) { return } + +# adb ecrit sa progression sur la sortie d'erreur, ce que PowerShell prend pour +# un echec. Sans ce relachement, une installation reussie interrompt le script. +$ErrorActionPreference = 'Continue' + +& $adb install -r "$stage\bin\pmserverApk.apk" 2>&1 | + Select-String -Pattern 'Success|Failure' | ForEach-Object { $_.Line } +# Le telephone voit le poste comme 127.0.0.1 par ce renvoi. +& $adb reverse tcp:8080 tcp:80 | Out-Null +& $adb shell am force-stop com.embarcadero.pmserverApk +& $adb shell am start -n com.embarcadero.pmserverApk/com.embarcadero.firemonkey.FMXNativeActivity | Out-Null diff --git a/android-client/web/app.html b/android-client/web/app.html new file mode 100644 index 0000000..8e23f73 --- /dev/null +++ b/android-client/web/app.html @@ -0,0 +1,396 @@ + + + + +Vault + + +
+
+
+
⚲
+ +
×
+
+
+
+
+
+ +
+
+ +

+
+
+
+ +
+ + diff --git a/android-client/web/web.rc b/android-client/web/web.rc new file mode 100644 index 0000000..124254c --- /dev/null +++ b/android-client/web/web.rc @@ -0,0 +1 @@ +PMAPP RCDATA "app.html" diff --git a/mainApk.pas b/mainApk.pas index f03129b..79babfe 100644 --- a/mainApk.pas +++ b/mainApk.pas @@ -2,13 +2,15 @@ unit mainApk; { Client Android en LECTURE SEULE : deverrouiller, chercher, copier. - Trois ecrans dans une seule forme, montres a tour de role - une forme par - ecran couterait un fichier .fmx chacun pour trois dispositions triviales. + DEUX MOITIES. Le deverrouillage est en FMX - il touche a la biometrie et au + Keystore, et tient en trois boutons. La liste et le detail sont une page + HTML rendue par le moteur du systeme (PMA.WebUI, android-client/web) : les + gabarits FMX se sont montres trop incertains sur mobile, et le moteur met en + forme l'arabe correctement sans qu'on ait rien a faire. - 1. Deverrouillage : ouvre le coffre local (biometrie), ou telecharge le - conteneur et le dechiffre si l'appareil n'en a pas encore. - 2. Liste : recherche + entrees. - 3. Detail : les champs d'une entree, mot de passe masque. + 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 @@ -69,19 +71,9 @@ const {$I android-client\PMA.LocalConfig.inc} type - /// Une ligne du detail, avant tout controle. Site, identifiant, mot de - /// passe et champs personnalises se ramenent tous a la meme chose : un - /// intitule, une valeur, et le fait qu'elle soit secrete ou non. Les traiter - /// separement dupliquerait revelation et copie quatre fois. - TDetRow = record - Caption, Value: string; - Secret: Boolean; - end; - TForm8 = class(TForm) private FVault: TVault; - FFiltered: TArray; // indices dans FVault, resultat de la recherche FCurrent: TVaultEntry; // L'ETag n'est conserve QUE si le dechiffrement qui a suivi a reussi : // envoyer If-None-Match sans detenir le clair correspondant fait @@ -101,51 +93,25 @@ type // --- ecran 1 : deverrouillage FLayUnlock: TLayout; FUrl, FToken, FPwd: TEdit; - FBtnOpen, FBtnSync, FBtnSettings, FBtnLog, FBtnHtml: TRectangle; - /// Sondage HTML, cree au premier appui seulement : un moteur de rendu - /// entier ne se paie pas au lancement pour un essai. - FLayWeb: TLayout; - FWeb: TWebBrowser; + FBtnOpen, FBtnSync, FBtnSettings, FBtnLog: TRectangle; FLaySettings: TLayout; FStatus: TLabel; FLog: TMemo; - // --- ecran 2 : liste - FLayList: TLayout; - FSearch: TEdit; - FSearchHint, FSearchClearMark: TLabel; - FSearchGlass: TCircle; - FSearchHandle: TLine; - FSearchClear: TRectangle; - /// Choix du dossier : un bouton peint, et un panneau de selection montre - /// a la demande. FFolders[0] est toujours « tous les dossiers ». - FBtnFolder: TRectangle; - FFolderPanel: TRectangle; - FFolderNames: TArray; - FFolderSel: Integer; - FList: TListBox; - FCount: TLabel; - /// Icones decodees une fois par coffre, pas a chaque frappe : la liste est - /// reconstruite a chaque caractere tape, et decoder du PNG a ce rythme se - /// voit. Cle = indice dans le coffre. - FIcons: TObjectDictionary; + // --- ecrans 2 et 3 : liste et detail, rendus 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; - // --- ecran 3 : detail - // Les lignes sont construites PAR ENTREE : leur nombre depend des champs - // personnalises. On garde de quoi les detruire et de quoi retrouver - // l'etiquette de valeur d'une ligne pour la reveler. - FLayDetail: TLayout; - FDetBody: TVertScrollBox; - FDetTitle, FDetToast: TLabel; - FRows: TArray; - FRowCtls: TArray; - FRowValues: TArray; - FRowShown: TArray; - - // --- TOTP : une ligne vivante, rafraichie chaque seconde + // --- TOTP : la seule ligne vivante, rafraichie chaque seconde FTotpTimer: TTimer; - FTotpValue: TLabel; - FTotpBar: TRectangle; FTotpCode: string; // --- presse-papiers @@ -155,21 +121,15 @@ type // --- verrouillage sur inactivite FIdleTimer: TTimer; FLastActivity: TDateTime; - /// Quand l'application est passee derriere, et quel ecran elle a quitte. - /// 0 = elle est au premier plan. + /// Quand l'application est passee derriere. 0 = elle est au premier plan. FBackgroundAt: TDateTime; - FHiddenOnDetail: Boolean; procedure Touch; procedure OnIdleTimer(Sender: TObject); procedure BuildUnlock; - procedure BuildList; - procedure BuildDetail; procedure ShowUnlock; procedure ShowList; - procedure ShowDetail(AVaultIndex: Integer); - procedure ClearDetailRows; procedure OnTotpTick(Sender: TObject); procedure DoOpenLocal(Sender: TObject); @@ -188,22 +148,20 @@ type procedure AdoptVault(const APlainJson: string); procedure LockVault; - procedure OnSearchChanged(Sender: TObject); - procedure OnSearchClear(Sender: TObject); - procedure OnRowCopyUser(Sender: TObject); - procedure OnRowCopyPwd(Sender: TObject); - procedure OnFolderTap(Sender: TObject); - procedure OnFolderPick(Sender: TObject); - procedure PopulateFolders; - procedure RebuildIcons; - procedure OnItemTap(const Sender: TCustomListBox; const AItem: TListBoxItem); - procedure OnRevealTap(Sender: TObject); - procedure OnCopyTap(Sender: TObject); - procedure OnBackTap(Sender: TObject); procedure OnToggleSettings(Sender: TObject); procedure OnToggleLog(Sender: TObject); - procedure OnHtmlTest(Sender: TObject); - procedure OnHtmlClose(Sender: TObject); + + // --- 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 OpenEntry(AVaultIndex: Integer); procedure OnClipTimer(Sender: TObject); procedure OnHardwareBack(Sender: TObject; var Key: Word; var KeyChar: WideChar; Shift: TShiftState); @@ -225,17 +183,10 @@ implementation uses PMA.Crypto, PMA.SyncClient, PMA.Store, PMA.Biometric, PMA.Totp, - PMA.ScreenGuard, PMA.Clipboard, PMA.Theme; + PMA.ScreenGuard, PMA.Clipboard, PMA.Theme, PMA.WebUI, System.JSON; {$R *.fmx} -const - // Puces en points de code, PAS en caracteres litteraux : un .pas sans BOM - // est lu comme de l'ANSI, et un bullet UTF-8 y devient trois glyphes. - BULLET = #$2022; - MASK = BULLET+BULLET+BULLET+BULLET+BULLET+BULLET+ - BULLET+BULLET+BULLET+BULLET+BULLET+BULLET; - { ---------------------------------------------------------------------------- Construction ---------------------------------------------------------------------------- } @@ -256,11 +207,9 @@ begin TintSystemBars(COL_BG_TOP, COL_BG); SecureScreen; // avant tout affichage de contenu FVault := TVault.Create; - FIcons := TObjectDictionary.Create([doOwnsValues]); - BuildDetail; // cree en dernier a l'ecran = au-dessus des autres - BuildList; - BuildUnlock; + BuildWeb; + BuildUnlock; // cree en dernier a l'ecran = au-dessus de la page FClipTimer := TTimer.Create(Self); FClipTimer.Enabled := False; @@ -298,7 +247,6 @@ end; destructor TForm8.Destroy; begin - FIcons.Free; FVault.Free; inherited; end; @@ -394,14 +342,6 @@ begin FBtnSettings := FlatButton(LRow, 'Server settings', OnToggleSettings); FBtnSettings.Align := TAlignLayout.Client; - // Sondage, pas une fonction : il repond a une seule question, celle de - // savoir si une page HTML peinte par le moteur du systeme rend mieux que - // ces controles-ci. A retirer des que la reponse est prise. - FBtnHtml := FlatButton(LRow, 'HTML', OnHtmlTest); - FBtnHtml.Align := TAlignLayout.Left; - FBtnHtml.Width := 90; - FBtnHtml.Margins.Right := 8; - FBtnSync := TopButton(FLayUnlock, 'Sync', DoSync); // Accentue : c'est l'action attendue quand aucun coffre n'est encore la. FBtnOpen := TopButton(FLayUnlock, 'Open vault', DoOpenLocal, 52, True); @@ -414,236 +354,13 @@ begin Tint(FStatus, 15, True); end; -procedure TForm8.BuildList; -var - LBar, LTop: TLayout; - LBtnLock: TRectangle; - LGlass: TCircle; - LHandle: TLine; -begin - FLayList := TLayout.Create(Self); - FLayList.Parent := Self; - FLayList.Align := TAlignLayout.Client; - FLayList.Visible := False; - - LBar := TLayout.Create(Self); - LBar.Parent := FLayList; - LBar.Align := TAlignLayout.Bottom; - LBar.Height := 52; - - LBtnLock := FlatButton(LBar, 'Lock', OnBackTap); - LBtnLock.Align := TAlignLayout.Left; - LBtnLock.Margins.Rect := RectF(16, 4, 0, 8); - LBtnLock.Width := 140; - LBtnLock.Tag := 1; // 1 = verrouiller, 0 = simple retour (voir OnBackTap) - - FCount := TLabel.Create(Self); - FCount.Parent := LBar; - FCount.Align := TAlignLayout.Client; - FCount.Margins.Rect := RectF(12, 4, 16, 8); - FCount.TextSettings.HorzAlign := TTextAlign.Trailing; - FCount.TextSettings.VertAlign := TTextAlign.Center; - Tint(FCount, 13, True); - - FList := TListBox.Create(Self); - FList.Parent := FLayList; - FList.Align := TAlignLayout.Client; - FList.Margins.Rect := RectF(8, 0, 8, 0); - FList.ItemHeight := 62; - FList.OnItemClick := OnItemTap; - // Sans cadre : la liste est posee sur le fond general, pas dans une boite. - // Le gabarit transparent existe dans les styles livres ; s'il manquait, on - // retomberait simplement sur l'apparence encadree. - FList.StyleLookup := 'transparentlistboxstyle'; - - LTop := TLayout.Create(Self); - LTop.Parent := FLayList; - LTop.Align := TAlignLayout.Top; - LTop.Height := 48; - LTop.Margins.Rect := RectF(8, 8, 8, 8); - - // Pas de filtre d'etiquette : la recherche texte couvre deja les etiquettes, - // en taper le nom suffit. Les dossiers, eux, ne se devinent pas. - // - // Bouton peint et non TComboBox : le combo etait l'un des deux derniers - // controles a porter encore le style, et il jurait avec le reste. - FBtnFolder := FlatButton(LTop, 'All folders', OnFolderTap); - FBtnFolder.Align := TAlignLayout.Right; - FBtnFolder.Width := 170; - FBtnFolder.Margins.Left := 8; - - // Le champ reste natif - il faut un clavier - et son fond vient desormais du - // style, recolore a la palette par make-style.ps1. PAS de rectangle derriere - // lui : il en resultait deux cadres arrondis emboites. - FSearch := TEdit.Create(Self); - FSearch.Parent := LTop; - FSearch.Align := TAlignLayout.Client; - // Le texte saisi commence apres la loupe. - FSearch.Padding.Left := 32; - FSearch.OnChangeTracking := OnSearchChanged; - - // Invite dessinee par nous, pas par TextPrompt : Dark.style ne comporte pas - // l'objet que le style est cense fournir pour l'afficher, et le champ - // restait donc vide et muet. HitTest desactive pour que le clic traverse - // jusqu'au champ. - // Loupe DESSINEE dans le champ. Un enfant qui ne fait que se peindre y est - // accepte - c'est le cliquable qui ne l'est pas. Un cercle et un manche - // plutot qu'un glyphe : aucune police n'est garantie sur tous les appareils. - FSearchGlass := TCircle.Create(FSearch); - LGlass := FSearchGlass; - LGlass.Parent := FSearch; - LGlass.Align := TAlignLayout.None; - LGlass.SetBounds(16, 15, 15, 15); - LGlass.Fill.Kind := TBrushKind.None; - LGlass.Stroke.Color := COL_MUTED; - LGlass.Stroke.Thickness := 2; - LGlass.HitTest := False; - - FSearchHandle := TLine.Create(FSearch); - LHandle := FSearchHandle; - LHandle.Parent := FSearch; - LHandle.Align := TAlignLayout.None; - LHandle.SetBounds(29, 28, 6, 6); - LHandle.LineType := TLineType.Diagonal; - LHandle.Stroke.Color := COL_MUTED; - LHandle.Stroke.Thickness := 2; - LHandle.HitTest := False; - - FSearchHint := TLabel.Create(FSearch); - FSearchHint.Parent := FSearch; - FSearchHint.Align := TAlignLayout.Client; - FSearchHint.Margins.Left := 42; // degage la loupe - FSearchHint.HitTest := False; - FSearchHint.Opacity := 0.45; - FSearchHint.Text := 'Search'; - - // Croix DANS le champ, et non plus a cote. Le premier essai avait echoue - // avec un TLabel, dont HitTest vaut faux par defaut ; j'en avais conclu trop - // vite qu'un enfant de TEdit ne recoit jamais les touches. Un TRectangle les - // prend. Sa place est occupee en permanence pour que la largeur du champ ne - // bouge pas ; seule la croix apparait. - FSearchClear := TRectangle.Create(FSearch); - FSearchClear.Parent := FSearch; - FSearchClear.Align := TAlignLayout.Right; - FSearchClear.Width := 46; - FSearchClear.Fill.Kind := TBrushKind.None; // invisible, mais cliquable - FSearchClear.Stroke.Kind := TBrushKind.None; - FSearchClear.OnClick := OnSearchClear; - - FSearchClearMark := TLabel.Create(FSearchClear); - FSearchClearMark.Parent := FSearchClear; - FSearchClearMark.Align := TAlignLayout.Client; - FSearchClearMark.HitTest := False; // le clic va au rectangle - FSearchClearMark.Text := 'X'; - FSearchClearMark.TextSettings.HorzAlign := TTextAlign.Center; - FSearchClearMark.TextSettings.VertAlign := TTextAlign.Center; - FSearchClearMark.Visible := False; - Tint(FSearchClearMark, 17, True); - - // Croix d'effacement, montree seulement quand il y a quelque chose a - // effacer. Un TLabel et non un bouton : dans un champ, une croix se touche, - // elle ne se dessine pas comme une commande. -end; - -/// Intitule discret au-dessus d'une valeur. Meme forme pour toutes les -/// lignes, y compris celle du TOTP. -/// AOrder fixe la place de la ligne dans la liste d'enfants du parent. -/// -/// SANS LUI L'ORDRE N'EST PAS STABLE : observe sur appareil, le formulaire -/// s'affichait dans le bon ordre a la premiere ouverture puis a l'envers apres -/// un verrouillage. Les conventions d'empilement de FMX different deja entre -/// TLayout et TVertScrollBox ; apres destruction et recreation des lignes, -/// elles ne sont meme plus constantes. On ne s'y fie donc pas du tout. -function MakeRow(AParent: TFmxObject; const ACaption: string; AOrder: Integer; - out AValue: TLabel): TLayout; -var - LCap: TLabel; - LBox: TRectangle; -begin - // Chaque champ dans son cadre, comme sur le poste Windows : c'est le cadre - // qui separe les valeurs, pas l'espacement. - LBox := Surface(AParent); - LBox.Align := TAlignLayout.Top; - LBox.Index := AOrder; - LBox.Height := 76; - LBox.Margins.Rect := RectF(12, 8, 12, 0); - - Result := TLayout.Create(nil); // detruite a la main, voir ClearDetailRows - Result.Parent := LBox; - Result.Align := TAlignLayout.Client; - Result.Margins.Rect := RectF(12, 8, 12, 8); - Result.TagObject := LBox; // le cadre meurt avec la ligne - - LCap := TLabel.Create(Result); - LCap.Parent := Result; - LCap.Align := TAlignLayout.Top; - LCap.Height := 18; - LCap.Text := ACaption; - SectionLabel(LCap); - - AValue := TLabel.Create(Result); - AValue.Parent := Result; - AValue.Align := TAlignLayout.Client; - Tint(AValue, 16); -end; - -function AddRowButton(ARow: TLayout; const AText: string; ATag: Integer; - AOnClick: TNotifyEvent): TRectangle; -begin - Result := FlatButton(ARow, AText, AOnClick); - Result.Align := TAlignLayout.Right; - Result.Margins.Rect := RectF(8, 6, 0, 6); - Result.Width := 96; - Result.Tag := ATag; - // Arrondi modere : ces boutons sont bas et larges, une pilule les rendait - // ovales. La forme pleinement arrondie reste aux actions principales. - SetCornerRadius(Result, 14); -end; - -procedure TForm8.BuildDetail; -var - LBtnBack: TRectangle; -begin - FLayDetail := TLayout.Create(Self); - FLayDetail.Parent := Self; - FLayDetail.Align := TAlignLayout.Client; - FLayDetail.Visible := False; - - LBtnBack := FlatButton(FLayDetail, 'Back', OnBackTap); - LBtnBack.Align := TAlignLayout.Bottom; - LBtnBack.Height := 52; - LBtnBack.Margins.Rect := RectF(16, 8, 16, 8); - LBtnBack.Tag := 0; - - FDetToast := TLabel.Create(Self); - FDetToast.Parent := FLayDetail; - FDetToast.Align := TAlignLayout.Bottom; - FDetToast.Height := 22; - FDetToast.Margins.Rect := RectF(12, 0, 12, 0); - FDetToast.StyledSettings := FDetToast.StyledSettings - [TStyledSetting.Size]; - FDetToast.TextSettings.Font.Size := 12; - FDetToast.Opacity := 0.7; - - // Le corps defilant n'est PAS cree ici : il est recree a chaque ouverture - // d'entree, voir ShowDetail. - - FDetTitle := TLabel.Create(Self); - FDetTitle.Parent := FLayDetail; - FDetTitle.Align := TAlignLayout.Top; - FDetTitle.Height := 44; - FDetTitle.Margins.Rect := RectF(12, 12, 12, 0); - FDetTitle.StyledSettings := FDetTitle.StyledSettings - [TStyledSetting.Size]; - FDetTitle.TextSettings.Font.Size := 22; -end; - -{ ---------------------------------------------------------------------------- - Navigation - ---------------------------------------------------------------------------- } - procedure TForm8.ShowUnlock; begin - FLayDetail.Visible := False; - FLayList.Visible := False; + // La vue du moteur est une vraie vue du systeme : elle se peint PAR-DESSUS + // tout ce que FMX dessine. Masquer le conteneur ne suffit pas toujours - + // masquer les deux, si. + FWeb.Visible := False; + FLayWeb.Visible := False; FLayUnlock.Visible := True; // Le bouton d'ouverture n'a de sens que si un coffre local existe ET qu'il @@ -667,229 +384,43 @@ end; procedure TForm8.ShowList; begin - // Quitter le detail rend ses valeurs en clair, et arrete le compte a rebours. - ClearDetailRows; + FTotpTimer.Enabled := False; FLayUnlock.Visible := False; - FLayDetail.Visible := False; - FLayList.Visible := True; - FSearch.Text := ''; - OnSearchChanged(nil); -end; - -function HumanSize(ABytes: Int64): string; -begin - if ABytes >= 1024 * 1024 then - Result := Format('%.1f Mo', [ABytes / (1024 * 1024)]) - else if ABytes >= 1024 then - Result := Format('%.0f Ko', [ABytes / 1024]) - else - Result := Format('%d o', [ABytes]); -end; - -procedure TForm8.ClearDetailRows; -var - LRow: TLayout; -begin - // Appelable avant la fin du constructeur (ShowList), d'ou la garde. - if FTotpTimer <> nil then FTotpTimer.Enabled := False; - FTotpValue := nil; - FTotpBar := nil; - FTotpCode := ''; - // LE CONTENEUR ENTIER EST DETRUIT, pas seulement ses lignes. - // - // Reutiliser le TVertScrollBox donnait un ordre d'affichage qui ALTERNAIT : - // correct a la premiere ouverture, inverse a la suivante. Ni la convention - // d'empilement ni un Index explicite ne l'ont stabilise. Puisque la premiere - // population est fiable, on n'en fait jamais de seconde - un conteneur neuf - // par entree. Ca coute la creation d'un controle, ca supprime une classe - // entiere de bizarreries. - // On detruit le CADRE, pas la ligne : la ligne est son enfant et part avec. - for LRow in FRowCtls do - if LRow.TagObject is TRectangle then TRectangle(LRow.TagObject).Free - else LRow.Free; - SetLength(FRowCtls, 0); - FreeAndNil(FDetBody); - SetLength(FRowValues, 0); - SetLength(FRowShown, 0); - SetLength(FRows, 0); -end; - -procedure TForm8.ShowDetail(AVaultIndex: Integer); -var - LMeta, LPwdCaption: string; - I, LOrder: Integer; - LRow: TLayout; - LValue: TLabel; - - procedure Add(const ACaption, AValue: string; ASecret: Boolean); - begin - if AValue = '' then Exit; // une ligne vide n'apprend rien - SetLength(FRows, Length(FRows) + 1); - FRows[High(FRows)].Caption := ACaption; - FRows[High(FRows)].Value := AValue; - FRows[High(FRows)].Secret := ASecret; - end; - -begin - Touch; - ClearDetailRows; - // Conteneur neuf. Align=Client, donc il ne dispute sa place ni au titre - // (Top) ni au pied (Bottom) : l'ordre de creation lui est indifferent. - FDetBody := TVertScrollBox.Create(Self); - FDetBody.Parent := FLayDetail; - FDetBody.Align := TAlignLayout.Client; - - FCurrent := FVault.Entry(AVaultIndex); - FDetTitle.Text := FCurrent.Display; - FDetToast.Text := ''; - - // Le corps d'une note est stocke dans le champ mot de passe : meme donnee, - // autre intitule, et pas de raison de la masquer comme un secret. - if FCurrent.IsNote then LPwdCaption := 'Content' else LPwdCaption := 'Password'; - - Add('Site', FCurrent.Site, False); - Add('Username', FCurrent.Username, False); - Add(LPwdCaption, FCurrent.Password, not FCurrent.IsNote); - for I := 0 to High(FCurrent.Fields) do - Add(FCurrent.Fields[I].Caption, FCurrent.Fields[I].Value, - FCurrent.Fields[I].Secret); - - LMeta := FCurrent.Folder; - if FCurrent.Tags <> '' then - begin - if LMeta <> '' then LMeta := LMeta + ' - '; - LMeta := LMeta + FCurrent.Tags; - end; - // Les pieces jointes ne sont pas encore enregistrables sur le telephone, - // mais taire leur existence serait pire : on saurait sur le poste qu'une - // entree porte un document, et pas ici. - // Taille dans l'INTITULE, pas collee au nom : un nom de fichier arabe suivi - // d'une taille latine melange deux sens de lecture dans la meme ligne, et le - // rendu bidirectionnel de FMX en fait n'importe quoi. Separes, chacun se - // lit dans son sens. - for I := 0 to High(FCurrent.Attachments) do - Add('Attachment - ' + HumanSize(FCurrent.Attachments[I].SizeBytes), - FCurrent.Attachments[I].FileName, False); - - Add('Folder / tags', LMeta, False); - // Le sous-type n'existe que pour les modeles (carte, cle SSH, serveur...) ; - // Add ignore une valeur vide, donc rien a tester ici. - Add('Type', FCurrent.Template, False); - // Horodatage tel quel : c'est de l'ISO 8601 UTC, lisible, et le reformater - // demanderait de decider d'un fuseau alors qu'il n'y a rien a arbitrer. - Add('Updated', FCurrent.UpdatedAt, False); - - SetLength(FRowValues, Length(FRows)); - SetLength(FRowShown, Length(FRows)); - SetLength(FRowCtls, Length(FRows)); - - // Le TOTP en tete d'ecran : c'est ce qu'on vient chercher sur un telephone. - // Seule ligne vivante, rafraichie chaque seconde. - LOrder := 0; - if FCurrent.Totp <> '' then - begin - LRow := MakeRow(FDetBody, '2FA code', LOrder, FTotpValue); - Inc(LOrder); - SetLength(FRowCtls, Length(FRowCtls) + 1); - FRowCtls[High(FRowCtls)] := LRow; - FTotpValue.TextSettings.Font.Size := 28; - FTotpValue.TextSettings.FontColor := COL_TEXT; - AddRowButton(LRow, 'Copy', -1, OnCopyTap); - - // Barre de progression sous le code, comme sur le poste : elle dit d'un - // coup d'oeil s'il reste le temps de le recopier. - FTotpBar := TRectangle.Create(LRow); - FTotpBar.Parent := LRow; - FTotpBar.Align := TAlignLayout.None; - FTotpBar.Fill.Color := COL_TEXT; - FTotpBar.Stroke.Kind := TBrushKind.None; - FTotpBar.XRadius := 1; - FTotpBar.YRadius := 1; - FTotpBar.HitTest := False; - FTotpBar.SetBounds(0, 56, 0, 3); // largeur posee a chaque seconde - OnTotpTick(nil); // pas d'attente d'une seconde a l'ouverture - FTotpTimer.Enabled := True; - end; - - for I := 0 to High(FRows) do - begin - LRow := MakeRow(FDetBody, FRows[I].Caption, LOrder, LValue); - Inc(LOrder); - FRowCtls[I] := LRow; - FRowValues[I] := LValue; - FRowShown[I] := False; - if FRows[I].Secret then - begin - LValue.Text := MASK; - AddRowButton(LRow, 'Show', I, OnRevealTap); - end - else - LValue.Text := FRows[I].Value; - AddRowButton(LRow, 'Copy', I, OnCopyTap); - end; - // La derniere ligne affichee touche sinon le bord du defilement, ce qui la - // fait passer pour tronquee alors qu'elle est juste collee. - // La derniere ligne affichee touche sinon le bord du defilement, ce qui la - // fait passer pour tronquee alors qu'elle est juste collee. - if (Length(FRows) > 0) and (FRowCtls[High(FRows)].TagObject is TRectangle) then - TRectangle(FRowCtls[High(FRows)].TagObject).Margins.Bottom := 12; - - FLayList.Visible := False; - FLayDetail.Visible := True; + FLayWeb.Visible := True; + FWeb.Visible := True; + FWebView := 'list'; + PushVault; end; procedure TForm8.OnTotpTick(Sender: TObject); var LLeft, LPeriod: Integer; begin - if FTotpValue = nil then - begin - FTotpTimer.Enabled := False; - Exit; - end; FTotpCode := TotpNow(FCurrent.Totp, LLeft, LPeriod); if FTotpCode = '' then begin // Un secret illisible ne doit pas passer pour un code : le dire. - FTotpValue.Text := 'unreadable secret'; + WebCall('PM.setTotp("unreadable secret", 0, 30)'); FTotpTimer.Enabled := False; Exit; end; - // Coupe en deux, comme partout ailleurs : six chiffres d'affilee se - // recopient mal. Le temps restant passe dans la barre, plus dans le texte. - FTotpValue.Text := Copy(FTotpCode, 1, Length(FTotpCode) div 2) + ' ' + - Copy(FTotpCode, Length(FTotpCode) div 2 + 1, MaxInt); - if (FTotpBar <> nil) and (LPeriod > 0) then - FTotpBar.Width := FTotpBar.ParentControl.Width * LLeft / LPeriod; -end; - -procedure TForm8.OnBackTap(Sender: TObject); -begin - // Tag 1 = le bouton "Verrouiller" de la liste, 0 = le "Retour" du detail. - if (Sender is TRectangle) and (TRectangle(Sender).Tag = 1) then - LockVault - else - ShowList; + 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; - // Le panneau des dossiers se ferme avant tout le reste : c'est ce que le - // bouton retour est cense faire d'abord quand quelque chose est ouvert. - if FFolderPanel <> nil then + 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 - FreeAndNil(FFolderPanel); - Key := 0; - Exit; - end; - if FLayDetail.Visible then - begin - ShowList; + WebCall('PM.back()'); + FWebView := 'list'; Key := 0; // consomme : sinon Android ferme l'application end - else if FLayList.Visible then + else begin LockVault; Key := 0; @@ -911,89 +442,151 @@ begin FLog.Visible := not FLog.Visible; end; -/// Sondage HTML : la meme liste, les memes blocs, mais peints par le moteur du -/// systeme au lieu de FMX. Ce qu'il faut regarder : le rendu de l'arabe, la -/// fluidite du defilement, et si la page se fond dans le degrade ou flotte -/// dans un rectangle blanc. Contenu factice - rien du coffre ne passe ici. -procedure TForm8.OnHtmlTest(Sender: TObject); -const - PAGE = - // SANS LA DECLARATION DE JEU DE CARACTERES l'arabe sort en charabia : le - // moteur recoit de l'UTF-8 et le lit en latin-1 faute d'indication. - '' + - '' + - '

Rendu HTML

' + - '
Rechercher
' + - '
G
Gitea' + - 'git.example.com
' + - '
' + - // L'ARABE EN REFERENCES NUMERIQUES, pas en clair : ce fichier n'a pas de - // marque d'ordre d'octets, Delphi le lit donc en ANSI et abimerait le - // litteral bien avant que le moteur de rendu le voie. Le detail affiche - // de l'arabe correct parce que celui-la vient du JSON, a l'execution. - '
م
' + - '
مرحبا بالعالم' + - 'اختبار العربية
' + - '
' + - '
N
Nextcloud' + - 'cloud.example.com
' + - '
'; -var - LBar: TLayout; - LBtn: TRectangle; -begin - if FLayWeb = nil then - begin - FLayWeb := TLayout.Create(Self); - FLayWeb.Parent := Self; - FLayWeb.Align := TAlignLayout.Client; - - // La barre est POSEE AVANT le navigateur et alignee en bas : sur Android - // le moteur est une vraie vue du systeme, qui se peint par-dessus tout ce - // que FMX dessine. Elle ne survivrait pas sous lui. - LBar := TLayout.Create(FLayWeb); - LBar.Parent := FLayWeb; - LBar.Align := TAlignLayout.Bottom; - LBar.Height := 60; - LBtn := FlatButton(LBar, 'Close', OnHtmlClose, True); - LBtn.Align := TAlignLayout.Client; - LBtn.Margins.Rect := RectF(16, 4, 16, 10); - - FWeb := TWebBrowser.Create(Self); - FWeb.Parent := FLayWeb; - FWeb.Align := TAlignLayout.Client; - // La page est en ASCII pur, d'ou les references numeriques plus haut : - // FMX appelle loadDataWithBaseURL en laissant l'encodage a nil, et une - // URL « data: », qui le porterait, est refusee par Navigate. - // ponytail: sonde. Une vraie page serait servie en HTTP, comme sur le - // poste, et la question de l'encodage ne se poserait plus. - FWeb.LoadFromStrings(PAGE, ''); - end; - FLayWeb.Visible := True; - FLayWeb.BringToFront; -end; - -procedure TForm8.OnHtmlClose(Sender: TObject); +{ ---------------------------------------------------------------------------- + La page : liste et detail + ---------------------------------------------------------------------------- } + +procedure TForm8.BuildWeb; begin + FLayWeb := TLayout.Create(Self); + FLayWeb.Parent := Self; + FLayWeb.Align := TAlignLayout.Client; FLayWeb.Visible := False; + + 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; + +procedure TForm8.WebCall(const AJavaScript: string); +begin + if FWebReady then + FWeb.EvaluateJavaScript(AJavaScript) + else + FWebPending := FWebPending + [AJavaScript]; +end; + +/// Passe une chaine a la page. Elle voyage en litteral JavaScript, d'ou +/// l'encodage JSON : un 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; + +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 + + 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 ---------------------------------------------------------------------------- } @@ -1009,12 +602,13 @@ begin // moyen de rouvrir le coffre sans relancer l'application. FETag := ''; FIdleTimer.Enabled := False; + FTotpTimer.Enabled := False; FVault.Clear; - FList.Clear; - FIcons.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. - ClearDetailRows; FCurrent := Default(TVaultEntry); ShowUnlock; end; @@ -1025,16 +619,14 @@ begin Log(' ' + FVault.LiveCount.ToString + ' entries, ' + FVault.TrashCount.ToString + ' in trash'); FVaultUnreadable := False; - RebuildIcons; - PopulateFolders; Touch; FIdleTimer.Enabled := True; // Deja dans l'application : reconstruire la liste SANS y ramener // l'utilisateur. Obligatoire meme s'il est dans le detail - les lignes de // la liste portent des indices vers l'ancien coffre, et un appui ouvrirait // la mauvaise entree. - if FLayList.Visible or FLayDetail.Visible then - OnSearchChanged(nil) + if FLayWeb.Visible then + PushVault else ShowList; end; @@ -1394,327 +986,6 @@ end; /// Data URI -> bitmap, ou nil. Les icones peuvent etre du SVG, que FMX ne /// sait pas charger : l'echec est normal et se solde par les initiales. -function BitmapFromDataUri(const AUri: string): TBitmap; -var - LComma: Integer; - LStream: TBytesStream; -begin - Result := nil; - if not AUri.StartsWith('data:') then Exit; - LComma := Pos(',', AUri); - if LComma = 0 then Exit; - try - LStream := TBytesStream.Create(TNetEncoding.Base64.DecodeStringToBytes( - Copy(AUri, LComma + 1, MaxInt))); - try - Result := TBitmap.Create; - Result.LoadFromStream(LStream); - finally - LStream.Free; - end; - except - FreeAndNil(Result); - end; -end; - -procedure TForm8.RebuildIcons; -var - I: Integer; - LBmp: TBitmap; -begin - FIcons.Clear; - // ponytail: tout decode a l'adoption du coffre, sur le thread principal. - // Quelques centaines de vignettes de 16 px ne se sentent pas ; deporter - // dans un thread le jour ou l'ouverture marque un temps. - for I := 0 to FVault.Count - 1 do - begin - if FVault.Entry(I).IconB64 = '' then Continue; - LBmp := BitmapFromDataUri(FVault.Entry(I).IconB64); - if LBmp <> nil then FIcons.Add(I, LBmp); - end; -end; - -procedure TForm8.PopulateFolders; -var - LF, LPrev: string; - I: Integer; -begin - // Le choix courant survit a un rafraichissement de fond : le voir retomber - // sur "tous" tout seul, sans avoir rien touche, serait deroutant. - LPrev := ''; - if (FFolderSel > 0) and (FFolderSel <= High(FFolderNames)) then - LPrev := FFolderNames[FFolderSel]; - - SetLength(FFolderNames, 1); - FFolderNames[0] := 'All folders'; - for LF in FVault.Folders do - begin - SetLength(FFolderNames, Length(FFolderNames) + 1); - FFolderNames[High(FFolderNames)] := LF; - end; - - FFolderSel := 0; - for I := 1 to High(FFolderNames) do - if FFolderNames[I] = LPrev then FFolderSel := I; - SetButtonText(FBtnFolder, FFolderNames[FFolderSel]); -end; - -/// Copie depuis la liste. Le Tag du bouton porte l'indice dans le coffre, pas -/// dans la liste affichee - la recherche renumerote les lignes, pas le coffre. -procedure TForm8.OnRowCopyUser(Sender: TObject); -begin - Touch; - if (Sender is TRectangle) and (TRectangle(Sender).Tag < FVault.Count) then - CopyToClipboard(FVault.Entry(TRectangle(Sender).Tag).Username, 'Username'); -end; - -procedure TForm8.OnRowCopyPwd(Sender: TObject); -begin - Touch; - if (Sender is TRectangle) and (TRectangle(Sender).Tag < FVault.Count) then - CopyToClipboard(FVault.Entry(TRectangle(Sender).Tag).Password, 'Password'); -end; - -procedure TForm8.OnSearchClear(Sender: TObject); -begin - FSearch.Text := ''; - // OnChangeTracking ne se declenche pas sur une affectation par code : la - // liste resterait filtree par une requete devenue vide. - OnSearchChanged(nil); -end; - -procedure TForm8.OnFolderTap(Sender: TObject); -var - I: Integer; - LRow: TRectangle; - LCard: TRectangle; - LBody: TVertScrollBox; - LH, LWanted, LMax: Single; -begin - Touch; - FreeAndNil(FFolderPanel); - if Length(FFolderNames) < 2 then Exit; // rien a choisir - - LH := 52; - - // Voile plein ecran : il assombrit le fond ET recoit le clic exterieur. - // Sans lui le panneau restait ouvert tant qu'on n'avait pas choisi - il - // faut toujours pouvoir renoncer. - FFolderPanel := TRectangle.Create(FLayList); - FFolderPanel.Parent := FLayList; - FFolderPanel.Align := TAlignLayout.Contents; - FFolderPanel.Fill.Color := TAlphaColor($99000000); - FFolderPanel.Stroke.Kind := TBrushKind.None; - FFolderPanel.OnClick := OnFolderPick; - FFolderPanel.Tag := -1; // -1 : renoncer, garder le choix courant - - LWanted := Length(FFolderNames) * LH + 12; - LMax := FLayList.Height - 140; - if LWanted > LMax then LWanted := LMax; - - LCard := Surface(FFolderPanel); - LCard.Align := TAlignLayout.None; - LCard.SetBounds(16, 66, FLayList.Width - 32, LWanted); - - // Defilant, car une longue liste de dossiers sortirait de l'ecran. Les - // lignes y sont POSEES A LA COORDONNEE, sans alignement : c'est ce qui rend - // l'ordre independant des conventions de FMX, instables des qu'on detruit - // et recree des enfants. - LBody := TVertScrollBox.Create(LCard); - LBody.Parent := LCard; - LBody.Align := TAlignLayout.Client; - LBody.Margins.Rect := RectF(6, 6, 6, 6); - LBody.ShowScrollBars := False; - - for I := 0 to High(FFolderNames) do - begin - LRow := FlatButton(LBody, FFolderNames[I], OnFolderPick, I = FFolderSel); - LRow.Align := TAlignLayout.None; - LRow.SetBounds(0, I * LH, LCard.Width - 24, LH - 6); - LRow.Tag := I; - end; -end; - -procedure TForm8.OnFolderPick(Sender: TObject); -begin - // Tag -1 : le voile, donc un clic a cote. On ferme sans rien changer. - if (Sender is TRectangle) and (TRectangle(Sender).Tag >= 0) then - FFolderSel := TRectangle(Sender).Tag; - SetButtonText(FBtnFolder, FFolderNames[FFolderSel]); - FreeAndNil(FFolderPanel); - OnSearchChanged(nil); -end; - -procedure TForm8.OnSearchChanged(Sender: TObject); -var - I: Integer; - LItem: TListBoxItem; - E: TVaultEntry; - LFolder: string; - LBmp: TBitmap; - LImg: TImage; - LBody, LActions: TLayout; - LCard, LBtnUser, LBtnPwd: TRectangle; - LTitle, LSub: TLabel; -begin - // ponytail: refonte complete de la liste a chaque frappe. Sur un coffre de - // quelques centaines d'entrees c'est imperceptible ; passer a un modele - // virtuel (TListView) le jour ou ca rame. - Touch; - // La loupe s'efface des qu'on tape : elle a servi a dire ce qu'est le - // champ, et une fois la saisie commencee elle n'apprend plus rien. - FSearchHint.Visible := FSearch.Text = ''; - FSearchGlass.Visible := FSearch.Text = ''; - FSearchHandle.Visible := FSearch.Text = ''; - FSearchClearMark.Visible := FSearch.Text <> ''; - LFolder := ''; - if (FFolderSel > 0) and (FFolderSel <= High(FFolderNames)) then - LFolder := FFolderNames[FFolderSel]; // 0 = tous les dossiers - FFiltered := FVault.Search(FSearch.Text, LFolder); - - FList.BeginUpdate; - try - FList.Clear; - for I := 0 to High(FFiltered) do - begin - E := FVault.Entry(FFiltered[I]); - LItem := TListBoxItem.Create(FList); - LItem.Parent := FList; - LItem.Height := 76; - LItem.Tag := FFiltered[I]; // indice dans le coffre, pas dans la liste - - // Chaque entree dans son bloc, comme les champs du detail : sur un fond - // en degrade, une simple ligne de texte flotte sans limite lisible. - LCard := Surface(LItem); - LCard.Align := TAlignLayout.Client; - LCard.Margins.Rect := RectF(4, 3, 4, 3); - // SANS CECI L'ENTREE N'EST PLUS CLIQUABLE : le bloc couvre toute la - // ligne et absorbe le tap, donc OnItemClick ne part jamais. Il ne sert - // qu'a peindre. Ses enfants, eux, gardent leur propre HitTest. - LCard.HitTest := False; - - // Copier sans ouvrir l'entree - le geste le plus frequent. Un Left et un - // Right, jamais deux fois le meme cote : leur ordre serait alors laisse - // au hasard. Ils prennent la hauteur du conteneur, ce qui evite de poser - // des coordonnees qui debordaient du bloc. - LActions := TLayout.Create(LCard); - LActions.Parent := LCard; - LActions.Align := TAlignLayout.Right; - LActions.Width := 150; - LActions.Margins.Rect := RectF(0, 8, 8, 8); - - // Une note n'a pas d'identifiant : un bouton qui copierait du vide. - if E.Username <> '' then - begin - LBtnUser := FlatButton(LActions, 'User', OnRowCopyUser); - LBtnUser.Align := TAlignLayout.Left; - LBtnUser.Width := 70; - LBtnUser.Tag := FFiltered[I]; - end; - - LBtnPwd := FlatButton(LActions, 'Pass', OnRowCopyPwd); - LBtnPwd.Align := TAlignLayout.Right; - LBtnPwd.Width := 70; - LBtnPwd.Tag := FFiltered[I]; - // CONTENU CONSTRUIT A LA MAIN, sans passer par Text/Detail/Bitmap ni par - // un StyleLookup. Ces gabarits n'existent pas dans tous les styles : - // avec Dark.style, 'listboxitembottomdetail' disparait et emporte - // l'identifiant, l'icone et la hauteur de ligne. Deux enfants seulement, - // alignes Left et Client - il n'y a alors pas d'ordre a deviner. - if FIcons.TryGetValue(FFiltered[I], LBmp) then - begin - LImg := TImage.Create(LCard); - LImg.Parent := LCard; - LImg.Align := TAlignLayout.Left; - LImg.Width := 40; - LImg.Margins.Rect := RectF(4, 8, 8, 8); - LImg.HitTest := False; // le clic doit atteindre la ligne - LImg.Bitmap.Assign(LBmp); - end; - - LBody := TLayout.Create(LCard); - LBody.Parent := LCard; - LBody.Align := TAlignLayout.Client; - LBody.Margins.Rect := RectF(8, 4, 8, 4); - LBody.HitTest := False; - - LTitle := TLabel.Create(LBody); - LTitle.Parent := LBody; - LTitle.Align := TAlignLayout.Top; - LTitle.Height := 26; - LTitle.HitTest := False; - LTitle.StyledSettings := LTitle.StyledSettings - [TStyledSetting.Size]; - LTitle.TextSettings.Font.Size := 16; - LTitle.Text := E.Display; - - // Align=Client sur le second : avec un Top et un Client, la place de - // chacun est determinee, quel que soit l'ordre des enfants. - LSub := TLabel.Create(LBody); - LSub.Parent := LBody; - LSub.Align := TAlignLayout.Client; - LSub.HitTest := False; - LSub.Opacity := 0.6; - LSub.StyledSettings := LSub.StyledSettings - [TStyledSetting.Size]; - LSub.TextSettings.Font.Size := 12; - LSub.Text := E.Username; - end; - finally - FList.EndUpdate; - end; - - if (FSearch.Text.Trim = '') and (LFolder = '') then - FCount.Text := FVault.LiveCount.ToString + ' entries' - else - FCount.Text := Length(FFiltered).ToString + ' / ' + - FVault.LiveCount.ToString; -end; - -procedure TForm8.OnItemTap(const Sender: TCustomListBox; const AItem: TListBoxItem); -begin - if AItem <> nil then ShowDetail(AItem.Tag); -end; - -{ ---------------------------------------------------------------------------- - Detail : reveler et copier - ---------------------------------------------------------------------------- } - -procedure TForm8.OnRevealTap(Sender: TObject); -var - I: Integer; -begin - Touch; - if not (Sender is TRectangle) then Exit; - I := TRectangle(Sender).Tag; - if (I < 0) or (I > High(FRows)) then Exit; - - FRowShown[I] := not FRowShown[I]; - if FRowShown[I] then - begin - FRowValues[I].Text := FRows[I].Value; - SetButtonText(TRectangle(Sender), 'Hide'); - end - else - begin - FRowValues[I].Text := MASK; - SetButtonText(TRectangle(Sender), 'Show'); - end; -end; - -procedure TForm8.OnCopyTap(Sender: TObject); -var - I: Integer; -begin - Touch; - if not (Sender is TRectangle) then Exit; - I := TRectangle(Sender).Tag; - // -1 : la ligne du TOTP, qui n'est pas dans FRows - sa valeur change chaque - // periode et ne vit que dans FTotpCode. Copie sans l'espace d'affichage. - if I = -1 then - CopyToClipboard(FTotpCode, '2FA code') - else if (I >= 0) and (I <= High(FRows)) then - CopyToClipboard(FRows[I].Value, FRows[I].Caption); -end; - procedure TForm8.CopyToClipboard(const AText, ALabel: string); begin if AText = '' then Exit; @@ -1727,11 +998,8 @@ begin // contenu son delai complet, pas le reste de celui du premier. FClipTimer.Enabled := False; FClipTimer.Enabled := True; - // ponytail: le message reste jusqu'a la prochaine navigation, pas de minuterie - // pour l'effacer. Un deuxieme TTimer pour deux secondes d'affichage serait - // plus de code que ce que ca apporte. - FDetToast.Text := ALabel + ' copied - clipboard cleared in ' + - CLIPBOARD_CLEAR_SECONDS.ToString + ' s'; + WebCall('PM.toast(' + JsArg(ALabel + ' copied - clipboard cleared in ' + + CLIPBOARD_CLEAR_SECONDS.ToString + ' s') + ')'); end; procedure TForm8.OnClipTimer(Sender: TObject); @@ -1757,11 +1025,10 @@ begin // 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 FLayList.Visible or FLayDetail.Visible then + if FLayWeb.Visible then begin - FHiddenOnDetail := FLayDetail.Visible; - FLayDetail.Visible := False; - FLayList.Visible := False; + FWeb.Visible := False; + FLayWeb.Visible := False; FLayUnlock.Visible := True; end; @@ -1783,10 +1050,11 @@ begin LockVault else begin - // Retour a temps : on rend l'ecran quitte, pas un autre. + // Retour a temps : on rend l'ecran quitte, pas un autre. La page a + // garde son etat, elle n'a ete que masquee. FLayUnlock.Visible := False; - FLayDetail.Visible := FHiddenOnDetail; - FLayList.Visible := not FHiddenOnDetail; + FLayWeb.Visible := True; + FWeb.Visible := True; Touch; end; FBackgroundAt := 0; diff --git a/pmserverApk.dpr b/pmserverApk.dpr index 0dd6b7d..7a321d3 100644 --- a/pmserverApk.dpr +++ b/pmserverApk.dpr @@ -23,7 +23,8 @@ uses PMA.Totp in 'android-client\PMA.Totp.pas', PMA.ScreenGuard in 'android-client\PMA.ScreenGuard.pas', PMA.Clipboard in 'android-client\PMA.Clipboard.pas', - PMA.Theme in 'android-client\PMA.Theme.pas'; + PMA.Theme in 'android-client\PMA.Theme.pas', + PMA.WebUI in 'android-client\PMA.WebUI.pas'; {$R *.res}