Password-Manager/android-client/PMA.VaultPatch.pas

unit PMA.VaultPatch;
{
  Modifier UN champ d'UNE entree dans l'instantane, sans toucher au reste.

  LA CONTRAINTE QUI GOUVERNE CETTE UNITE. TVault ne lit qu'une partie des
  champs : il ignore `content_b64` des pieces jointes, `created_at`, l'avatar du
  compte, les tombstones, et tout ce que le poste ajoutera demain. Reserialiser
  le coffre a partir de ce qu'il a compris EFFACERAIT tout cela - et le poste
  adopterait cette version amputee au tirage suivant, la fusion etant un
  dernier-ecrit-gagne sur `updated_at`. La perte serait silencieuse et
  definitive.

  Donc on ne reconstruit rien : on prend le JSON RECU, on change une valeur
  dedans, et on rend le reste tel quel. Ce que le telephone ne comprend pas
  voyage intact, par construction plutot que par vigilance.

  COROLLAIRE SUR LA FUSION. Comme le patch s'applique a l'instantane qu'on
  vient de tirer, il n'y a pas de fusion a ecrire : ce qui n'est pas touche est
  deja la version la plus recente du serveur. Le seul conflit possible est
  qu'un autre appareil publie entre notre lecture et notre ecriture, et Gitea
  le refuse par le sha (409) - il suffit alors de recommencer.
}

interface

uses
  System.SysUtils, System.JSON, System.DateUtils;

type
  EPMAPatch = class(Exception);

/// Remplace AField de l'entree AUuid par AValue, et bump `updated_at`.
/// Rend le JSON complet, tout le reste inchange. Leve si l'entree est absente -
/// ce qui veut dire que le distant ne la contient pas (supprimee ailleurs), et
/// ecrire quand meme la ferait reapparaitre.
function PatchEntryField(const APlainJson, AUuid, AField, AValue: string): string;

/// Un instantane vide, au nom de ce compte. Sert a l'inscription depuis le
/// telephone : meme forme que ce qu'ecrit le poste, pour qu'un coffre ne
/// naisse pas dans un dialecte a part.
function NewEmptySnapshot(const AUsername: string): string;

/// Ajoute une entree a l'instantane et rend le JSON complet.
///
/// LA MEME FORME QUE CE QU'ECRIT LE POSTE, cles vides comprises : une entree
/// nee ici sera relue la-bas, et une cle absente ne se comporte pas toujours
/// comme une cle vide. `folder` vaut 'All' parce que c'est le dossier par
/// defaut du poste, pas parce que c'est joli.
///
/// Un uuid neuf, et lui seul : pas de tombstone, on ne supprime pas encore.
function AddEntry(const APlainJson, ATitle, ASite, AUsername, APassword,
  AKind, AFolder: string): string;

/// Retire une entree de l'instantane et laisse une PIERRE TOMBALE a sa place.
///
/// LES DEUX, SINON RIEN. Retirer la ligne sans la tombstone ne supprime pas :
/// le poste tient toujours la sienne, et le prochain tirage la ramenerait comme
/// une entree qu'on n'a jamais eue. C'est la tombstone qui dit "celle-ci a ete
/// supprimee, et a telle heure" - et l'heure compte, parce que l'arbitrage du
/// poste garde une entree modifiee APRES la suppression plutot que de la tuer
/// une seconde fois.
///
/// SANS RETOUR depuis le telephone : il n'y a pas de corbeille ici. Celle du
/// poste est un drapeau `deleted` qui ne voyage pas dans la synchronisation ;
/// une suppression qui s'y arreterait ne se propagerait donc nulle part.
function DeleteEntry(const APlainJson, AUuid: string): string;

/// Duplique une entree : meme contenu, uuid neuf, nom suffixe.
///
/// COPIE INTEGRALE, pieces jointes comprises. Le poste fait de meme, et une
/// copie qui perdrait le document attache serait une surprise le jour ou l'on
/// s'en apercevrait - c'est-a-dire trop tard. Le prix est un instantane plus
/// lourd a publier ; il se voit tout de suite, lui.
function DuplicateEntry(const APlainJson, AUuid: string): string;

/// Le contenu base64 d'une piece jointe, relu dans l'instantane BRUT.
///
/// TVault le jette expres a la lecture - une seule piece jointe faisait passer
/// le cache de 13 a 174 Ko, et le garder en memoire pour tout le coffre alors
/// que rien ne l'affiche serait payer sans rien acheter. Il ne se relit donc
/// qu'ici, au moment ou quelqu'un demande a l'enregistrer, et pour une seule
/// entree.
///
/// Rend '' si l'entree, le rang ou le contenu manquent - une piece jointe
/// listee sans contenu existe : le poste peut avoir echoue a le joindre a
/// l'instantane.
function AttachmentContent(const APlainJson, AUuid: string;
  AIndex: Integer): string;

/// Fond l'instantane LOCAL dans l'instantane DISTANT et rend le resultat.
///
/// LE DISTANT SERT DE BASE, jamais le local. Il porte ce que le telephone ne
/// sait pas reconstruire - le contenu des pieces jointes, l'avatar du compte,
/// la couleur des dossiers, et tout ce que le poste ajoutera demain. Repartir
/// du local amputerait tout cela, et le poste adopterait la version amputee au
/// tirage suivant : la meme perte silencieuse et definitive contre laquelle
/// cette unite entiere est ecrite.
///
/// L'arbitrage est celui du poste, terme a terme : dernier ecrit gagnant sur
/// `updated_at`, et une pierre tombale l'emporte sur une entree plus ancienne
/// qu'elle. Les horodatages sont de l'ISO 8601 UTC des deux cotes,
/// millisecondes comprises, donc l'ordre lexicographique EST l'ordre
/// chronologique - aucune date a analyser.
///
/// Une entree sans uuid est ignoree : rien ne permettrait de la reconnaitre
/// chez l'autre, et l'ajouter en creerait un doublon a chaque fusion.
function MergeSnapshots(const ALocalJson, ARemoteJson: string): string;

/// Horodatage UTC au format que tout le reste emploie (toISOString cote JS).
/// MELANGER heure locale et UTC a deja decale l'arbitrage de la fusion une
/// fois : il n'y a qu'une source d'heure ici, et elle est en UTC.
function NowUtcIso: string;

implementation

function NowUtcIso: string;
begin
  Result := FormatDateTime('yyyy-mm-dd"T"hh:nn:ss.zzz"Z"',
    TTimeZone.Local.ToUniversalTime(Now));
end;

function NewEmptySnapshot(const AUsername: string): string;
var
  LRoot: TJSONObject;
begin
  LRoot := TJSONObject.Create;
  try
    // Les memes cles que buildSyncSnapshot, tableaux vides compris : un lecteur
    // qui trouve la cle absente et un lecteur qui la trouve vide ne se
    // comportent pas forcement pareil, et ce coffre sera lu par le poste.
    LRoot.AddPair('version', TJSONNumber.Create(1));
    LRoot.AddPair('snapshot_at', NowUtcIso);
    LRoot.AddPair('username', AUsername);
    LRoot.AddPair('folders', TJSONArray.Create);
    LRoot.AddPair('avatar_b64', '');
    LRoot.AddPair('entries', TJSONArray.Create);
    LRoot.AddPair('tombstones', TJSONArray.Create);
    Result := LRoot.ToJSON;
  finally
    LRoot.Free;
  end;
end;

/// L'heure de suppression retenue pour un uuid, ou '' s'il n'en a pas.
/// La plus recente des deux listes : une entree ressuscitee puis resupprimee
/// doit rester supprimee.
function TombstoneTime(const AStones: TJSONArray; const AUuid: string): string;
var
  I: Integer;
  LObj: TJSONObject;
  LWhen: string;
begin
  Result := '';
  if AStones = nil then Exit;
  for I := 0 to AStones.Count - 1 do
  begin
    if not (AStones.Items[I] is TJSONObject) then Continue;
    LObj := AStones.Items[I] as TJSONObject;
    if LObj.GetValue<string>('uuid', '') <> AUuid then Continue;
    LWhen := LObj.GetValue<string>('deleted_at', '');
    if LWhen > Result then Result := LWhen;
  end;
end;

/// Copie profonde d'un objet JSON : le reparser est le moyen le plus court, et
/// le seul qui n'oublie aucun champ.
/// Inscrit un dossier dans la liste du coffre s'il n'y figure pas deja.
///
/// Ranger une entree dans un dossier ne suffit pas : c'est `folders` qui peuple
/// la colonne du poste, et un nom qui n'y figure pas donne une entree rangee
/// dans un dossier que rien n'affiche - elle semble disparue. Les deux vont
/// donc ensemble, et 'All' ne s'inscrit jamais : c'est le defaut, pas un
/// dossier.
procedure EnsureFolder(const ARoot: TJSONObject; const AName: string);
var
  LFolders: TJSONArray;
  LObj: TJSONObject;
  I: Integer;
begin
  if (AName = '') or (AName = 'All') then Exit;
  if not ARoot.TryGetValue<TJSONArray>('folders', LFolders) then
  begin
    LFolders := TJSONArray.Create;
    ARoot.AddPair('folders', LFolders);
  end;
  for I := 0 to LFolders.Count - 1 do
    if (LFolders.Items[I] is TJSONObject) and
       ((LFolders.Items[I] as TJSONObject).GetValue<string>('name', '') = AName) then
      Exit;
  LObj := TJSONObject.Create;
  LObj.AddPair('name', AName);
  // Le poste lit aussi 'color' et 'icon' ; vides, il met ses defauts.
  LObj.AddPair('color', '');
  LObj.AddPair('icon', '');
  LFolders.AddElement(LObj);
end;

function CloneJson(const AObj: TJSONObject): TJSONObject;
begin
  Result := TJSONObject.ParseJSONValue(AObj.ToJSON) as TJSONObject;
end;

function MergeSnapshots(const ALocalJson, ARemoteJson: string): string;
var
  LLocal, LMerged: TJSONObject;
  LLocalEntries, LOutEntries, LLocalStones, LOutStones: TJSONArray;
  LEntry, LOther: TJSONObject;
  I, J: Integer;
  LUuid, LMine, LTheirs, LKilled: string;
  LFound: Boolean;
begin
  LLocal := TJSONObject.ParseJSONValue(ALocalJson) as TJSONObject;
  if LLocal = nil then raise EPMAPatch.Create('Instantane local illisible');
  try
    LMerged := TJSONObject.ParseJSONValue(ARemoteJson) as TJSONObject;
    if LMerged = nil then raise EPMAPatch.Create('Instantane distant illisible');
    try
      if not LMerged.TryGetValue<TJSONArray>('entries', LOutEntries) then
        raise EPMAPatch.Create('Instantane distant sans tableau "entries"');
      if not LMerged.TryGetValue<TJSONArray>('tombstones', LOutStones) then
      begin
        LOutStones := TJSONArray.Create;
        LMerged.AddPair('tombstones', LOutStones);
      end;

      // 1. Les pierres tombales locales rejoignent celles du distant. Avant les
      //    entrees : l'etape suivante s'en sert pour arbitrer.
      if LLocal.TryGetValue<TJSONArray>('tombstones', LLocalStones) then
        for I := 0 to LLocalStones.Count - 1 do
          if LLocalStones.Items[I] is TJSONObject then
            LOutStones.AddElement(CloneJson(LLocalStones.Items[I] as TJSONObject));

      // 2. Chaque entree locale : absente du distant on l'ajoute, presente on
      //    garde la plus recente des deux.
      if LLocal.TryGetValue<TJSONArray>('entries', LLocalEntries) then
        for I := 0 to LLocalEntries.Count - 1 do
        begin
          if not (LLocalEntries.Items[I] is TJSONObject) then Continue;
          LEntry := LLocalEntries.Items[I] as TJSONObject;
          LUuid := LEntry.GetValue<string>('uuid', '');
          if LUuid = '' then Continue;
          LMine := LEntry.GetValue<string>('updated_at', '');

          LFound := False;
          for J := 0 to LOutEntries.Count - 1 do
          begin
            if not (LOutEntries.Items[J] is TJSONObject) then Continue;
            LOther := LOutEntries.Items[J] as TJSONObject;
            if LOther.GetValue<string>('uuid', '') <> LUuid then Continue;
            LFound := True;
            LTheirs := LOther.GetValue<string>('updated_at', '');
            if LMine > LTheirs then
            begin
              LOutEntries.Remove(J).Free;
              LOutEntries.AddElement(CloneJson(LEntry));
            end;
            Break;
          end;
          if not LFound then LOutEntries.AddElement(CloneJson(LEntry));
        end;

      // 3. Une pierre tombale posterieure a l'entree la retire. Posterieure
      //    SEULEMENT : une entree modifiee apres coup a ete ressuscitee
      //    volontairement, et la retuer effacerait ce geste.
      for J := LOutEntries.Count - 1 downto 0 do
      begin
        if not (LOutEntries.Items[J] is TJSONObject) then Continue;
        LOther := LOutEntries.Items[J] as TJSONObject;
        LKilled := TombstoneTime(LOutStones, LOther.GetValue<string>('uuid', ''));
        if (LKilled <> '') and (LKilled > LOther.GetValue<string>('updated_at', '')) then
          LOutEntries.Remove(J).Free;
      end;

      Result := LMerged.ToJSON;
    finally
      LMerged.Free;
    end;
  finally
    LLocal.Free;
  end;
end;

function AttachmentContent(const APlainJson, AUuid: string;
  AIndex: Integer): string;
var
  LRoot, LEntry: TJSONObject;
  LEntries, LAtt: TJSONArray;
  I: Integer;
begin
  Result := '';
  if (AUuid = '') or (AIndex < 0) then Exit;
  LRoot := TJSONObject.ParseJSONValue(APlainJson) as TJSONObject;
  if LRoot = nil then Exit;
  try
    if not LRoot.TryGetValue<TJSONArray>('entries', LEntries) then Exit;
    for I := 0 to LEntries.Count - 1 do
    begin
      if not (LEntries.Items[I] is TJSONObject) then Continue;
      LEntry := LEntries.Items[I] as TJSONObject;
      if LEntry.GetValue<string>('uuid', '') <> AUuid then Continue;
      if not LEntry.TryGetValue<TJSONArray>('attachments', LAtt) then Exit;
      if AIndex >= LAtt.Count then Exit;
      if not (LAtt.Items[AIndex] is TJSONObject) then Exit;
      Result := (LAtt.Items[AIndex] as TJSONObject)
                  .GetValue<string>('content_b64', '');
      Exit;
    end;
  finally
    LRoot.Free;
  end;
end;

function DuplicateEntry(const APlainJson, AUuid: string): string;
var
  LRoot, LEntry, LCopy: TJSONObject;
  LEntries: TJSONArray;
  I: Integer;
  LNow, LTitle: string;
begin
  if AUuid = '' then
    raise EPMAPatch.Create('Entree sans uuid : rien a dupliquer');

  LRoot := TJSONObject.ParseJSONValue(APlainJson) as TJSONObject;
  if LRoot = nil then
    raise EPMAPatch.Create('Instantane illisible');
  try
    if not LRoot.TryGetValue<TJSONArray>('entries', LEntries) then
      raise EPMAPatch.Create('Instantane sans tableau "entries"');

    LCopy := nil;
    for I := 0 to LEntries.Count - 1 do
    begin
      if not (LEntries.Items[I] is TJSONObject) then Continue;
      LEntry := LEntries.Items[I] as TJSONObject;
      if LEntry.GetValue<string>('uuid', '') <> AUuid then Continue;
      // Reparser plutot que recopier champ par champ : c'est le seul moyen qui
      // n'oublie rien de ce que le telephone ne comprend pas.
      LCopy := CloneJson(LEntry);
      Break;
    end;
    if LCopy = nil then
      raise EPMAPatch.CreateFmt('Entree %s introuvable', [AUuid]);

    LNow := NowUtcIso;
    LCopy.RemovePair('uuid').Free;
    LCopy.AddPair('uuid', LowerCase(Copy(GUIDToString(TGUID.NewGuid), 2, 36)));
    LCopy.RemovePair('created_at').Free;
    LCopy.AddPair('created_at', LNow);
    LCopy.RemovePair('updated_at').Free;
    LCopy.AddPair('updated_at', LNow);
    // Le nom change, sinon les deux lignes sont indiscernables dans la liste.
    // Retirer PUIS ajouter, comme partout ici : AddPair seul laisserait deux
    // paires 'title', et le lecteur prendrait la premiere - donc l'ancienne.
    LTitle := Trim(LCopy.GetValue<string>('title', '') + ' (copy)');
    LCopy.RemovePair('title').Free;
    LCopy.AddPair('title', LTitle);
    LEntries.AddElement(LCopy);

    Result := LRoot.ToJSON;
  finally
    LRoot.Free;
  end;
end;

function DeleteEntry(const APlainJson, AUuid: string): string;
var
  LRoot, LEntry, LStone: TJSONObject;
  LEntries, LStones: TJSONArray;
  I: Integer;
  LFound: Boolean;
begin
  if AUuid = '' then
    raise EPMAPatch.Create('Entree sans uuid : rien a supprimer chez le distant');

  LRoot := TJSONObject.ParseJSONValue(APlainJson) as TJSONObject;
  if LRoot = nil then
    raise EPMAPatch.Create('Instantane illisible');
  try
    if not LRoot.TryGetValue<TJSONArray>('entries', LEntries) then
      raise EPMAPatch.Create('Instantane sans tableau "entries"');

    LFound := False;
    for I := 0 to LEntries.Count - 1 do
    begin
      if not (LEntries.Items[I] is TJSONObject) then Continue;
      LEntry := LEntries.Items[I] as TJSONObject;
      if LEntry.GetValue<string>('uuid', '') <> AUuid then Continue;
      // Remove REND la valeur retiree : a l'appelant de la liberer.
      LEntries.Remove(I).Free;
      LFound := True;
      Break;
    end;

    if not LFound then
      raise EPMAPatch.CreateFmt(
        'Entree %s absente du distant - supprimee ailleurs ?', [AUuid]);

    // Le tableau peut manquer : un conteneur ecrit par un poste qui n'avait
    // encore rien supprime n'a aucune raison de le porter.
    if not LRoot.TryGetValue<TJSONArray>('tombstones', LStones) then
    begin
      LStones := TJSONArray.Create;
      LRoot.AddPair('tombstones', LStones);
    end;
    LStone := TJSONObject.Create;
    LStone.AddPair('uuid', AUuid);
    LStone.AddPair('deleted_at', NowUtcIso);
    LStones.AddElement(LStone);

    Result := LRoot.ToJSON;
  finally
    LRoot.Free;
  end;
end;

function AddEntry(const APlainJson, ATitle, ASite, AUsername, APassword,
  AKind, AFolder: string): string;
var
  LRoot, LEntry: TJSONObject;
  LEntries: TJSONArray;
  LNow: string;
begin
  LRoot := TJSONObject.ParseJSONValue(APlainJson) as TJSONObject;
  if LRoot = nil then
    raise EPMAPatch.Create('Snapshot is not a JSON object');
  try
    LEntries := LRoot.GetValue('entries') as TJSONArray;
    if LEntries = nil then
      raise EPMAPatch.Create('Snapshot has no entries array');

    LNow := NowUtcIso;
    LEntry := TJSONObject.Create;
    // Minuscules et sans accolades : la forme que tout le reste emploie.
    LEntry.AddPair('uuid', LowerCase(Copy(GUIDToString(TGUID.NewGuid), 2, 36)));
    LEntry.AddPair('title', ATitle);
    LEntry.AddPair('site', ASite);
    LEntry.AddPair('username', AUsername);
    // Le corps d'une note EST son mot de passe cote stockage - il n'y a pas de
    // colonne separee, ni ici ni sur le poste.
    LEntry.AddPair('password', APassword);
    if AFolder <> '' then LEntry.AddPair('folder', AFolder)
                      else LEntry.AddPair('folder', 'All');
    EnsureFolder(LRoot, AFolder);
    LEntry.AddPair('tags', TJSONArray.Create);
    LEntry.AddPair('totp_secret', '');
    LEntry.AddPair('kind', AKind);
    LEntry.AddPair('template', '');
    LEntry.AddPair('custom_fields', TJSONArray.Create);
    LEntry.AddPair('attachments', TJSONArray.Create);
    LEntry.AddPair('icon_b64', '');
    LEntry.AddPair('icon_custom', TJSONNumber.Create(0));
    LEntry.AddPair('created_at', LNow);
    LEntry.AddPair('updated_at', LNow);
    LEntries.AddElement(LEntry);

    Result := LRoot.ToJSON;
  finally
    LRoot.Free;
  end;
end;

function PatchEntryField(const APlainJson, AUuid, AField, AValue: string): string;
var
  LRoot, LEntry: TJSONObject;
  LEntries: TJSONArray;
  I: Integer;
  LFound: Boolean;
begin
  if AUuid = '' then
    raise EPMAPatch.Create('Entree sans uuid : rien a retrouver chez le distant');

  LRoot := TJSONObject.ParseJSONValue(APlainJson) as TJSONObject;
  if LRoot = nil then
    raise EPMAPatch.Create('Instantane illisible');
  try
    if not LRoot.TryGetValue<TJSONArray>('entries', LEntries) then
      raise EPMAPatch.Create('Instantane sans tableau "entries"');

    LFound := False;
    for I := 0 to LEntries.Count - 1 do
    begin
      if not (LEntries.Items[I] is TJSONObject) then Continue;
      LEntry := LEntries.Items[I] as TJSONObject;
      if LEntry.GetValue<string>('uuid', '') <> AUuid then Continue;

      // RemovePair puis AddPair : AddPair seul ajouterait un DOUBLON, et le
      // lecteur prendrait le premier - donc l'ancienne valeur.
      LEntry.RemovePair(AField).Free;
      LEntry.AddPair(AField, AValue);

      // Sans ce bump, la modification voyage mais les autres appareils
      // l'ignorent : leur arbitrage compare `updated_at`, et le notre serait
      // reste plus ancien que le leur.
      LEntry.RemovePair('updated_at').Free;
      LEntry.AddPair('updated_at', NowUtcIso);
      if AField = 'folder' then EnsureFolder(LRoot, AValue);

      LFound := True;
      Break;
    end;

    if not LFound then
      raise EPMAPatch.CreateFmt(
        'Entree %s absente du distant - supprimee ailleurs ?', [AUuid]);

    Result := LRoot.ToJSON;
  finally
    LRoot.Free;
  end;
end;

end.