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}