Постановка задачи на пальцах

Формализация

Решение в лоб

Транспорт

Первый вариант кода

TForm1 = class(TForm)
  TCPClient: TIdTCPClient;
  ButtonSync: TButton;
  StoredProcLists: TFDStoredProc;
  procedure ButtonSyncClick(Sender: TObject);
end;

procedure TForm1.ButtonSyncClick(Sender: TObject);
var
  Handler: TIdIOHandler;
begin
  TCPClient.Connect;

  Handler := TCPClient.IOHandler;

  // Определение списков для синхронизации
  ...

  // Синхронизация справочника товаров
  ...

  // Синхронизация пользователей
  ...

  // Синхронизация списков:

  // 1. Добавление на сервер
  ...

  // 2. Добавление на клиента
  ...

  // 3. Обмен изменениями

  // Передача списков, требующих обмена изменениями.
  StoredProcLists.Open;
  Handler.Write(StoredProcLists.RecordCount);

  while not StoredProcLists.Eof do
  begin
    Handler.Write( StoredProcLists.FieldByName('ListID').AsInteger );

    Handler.Write( Length(StoredProcLists.FieldByName('ListHash').AsBytes) );
    Handler.Write( StoredProcLists.FieldByName('ListHash').AsBytes );

    Handler.Write( Length(StoredProcLists.FieldByName('ListUsersHash').AsBytes) );
    Handler.Write( StoredProcLists.FieldByName('ListUsersHash').AsBytes );

    Handler.Write( Length(StoredProcLists.FieldByName('ListItemsHash').AsBytes) );
    Handler.Write( StoredProcLists.FieldByName('ListItemsHash').AsBytes );

    StoredProcLists.Next;
  end;

  StoredProcLists.Close;

  // Реакция на ответ сервера.
  if Handler.ReadByte = 1 then // Конец синхронизации?
    ... // Да - прерываем выполнение.
  else
    ... // Нет - дальнейшие шаги протокола.

  TCPClient.Disconnect;
end;

• Замыливание, размытие структуры протокола, его логических этапов и передаваемых данных, что чрезвычайно затруднит доработки в будущем.
• Привязка к конкретной сетевой библиотеке (Indy): в случае её смены, потребуется серьёзная работа по скрупулёзному прочёсыванию всего объёма кода, которая чревата ошибками.
• Аналогичная привязка не просто к источнику данных (БД), но и на компоненты доступа к ним (FireDAC) – это влечёт ту же проблему.

Первое приближение

Протокол

unit Net.Protocol;

interface

uses
  IdIOHandler;

type
  TNetTransport = TIdIOHandler;

  TNetProtocol = class abstract
  protected
    FTransport: TNetTransport;
  public
    constructor Create(const Transport: TNetTransport);
    procedure RunExchange; virtual; abstract;
  end;

implementation

constructor TNetProtocol.Create(const Transport: TNetTransport);
begin
  FTransport := Transport;
end;

end.

procedure TForm1.ButtonSyncClick(Sender: TObject);
var
  Protocol: TClientProtocol;
begin
  TCPClient.Connect;

  Protocol := TClientProtocol.Create(TCPClient.IOHandler);
  try
    Protocol.RunExchange;
  finally
    Protocol.Free;
  end;

  TCPClient.Disconnect;
end;

Пакет

unit Net.Packet;

interface

uses
  Net.Protocol;

type
  TPacket = class abstract
  public
    type
      TPacketKind = UInt16;
  protected
    FTransport: TNetTransport;
    function Kind: TPacketKind; virtual; abstract;
  public
    constructor Create(const Transport: TNetTransport);

    procedure Send;
    procedure Receive;
  end;

implementation

constructor TPacket.Create(const Transport: TNetTransport);
begin
  FTransport := Transport;
end;

procedure TPacket.Send;
begin
  FTransport.Write(Kind);
end;

procedure TPacket.Receive;
var
  ActualKind: TPacketKind;
begin
  ActualKind := FTransport.ReadUInt16;

  if Kind <> ActualKind then
    // Реакция на неожидаемый пакет.
    ...
end;

end.

unit Sync.Packets;

interface

uses
  System.Generics.Collections,
  Net.Packet;

type
  TListHashesPacket = class(TPacket)
  private
    const
      PacketKind = 1;
  public
    type
      THashes = class
      strict private
        FHash: string;
        FItemsHash: string;
        FUsersHash: string;
      public
        property Hash: string read FHash write FHash;
        property UsersHash: string read FUsersHash write FUsersHash;
        property ItemsHash: string read FItemsHash write FItemsHash;
      end;

      TListHashes = TObjectDictionary<Integer, THashes>; // Ключ словаря - ID списка.
  private
    FHashes: TListHashes;
  protected
    function Kind: TPacket.TPacketKind; override;
  public
    property Hashes: TListHashes read FHashes write FHashes;
  end;

  TListHashesResponsePacket = class(TPacket)
  private
    const
      PacketKind = 2;
  private
    FHashesMatched: Boolean;
  protected
    function Kind: TPacket.TPacketKind; override;
  public
    property HashesMatched: Boolean read FHashesMatched write FHashesMatched;
  end;

  // Прочие пакеты протокола.
  ...

implementation

function TListHashesPacket.Kind: TPacket.TPacketKind;
begin
  Result := PacketKind;
end;

function TListHashesResponsePacket.Kind: TPacket.TPacketKind;
begin
  Result := PacketKind;
end;

end.

Реализация протокола

unit Sync.Protocol.Client;

interface

uses
  Net.Protocol;

type
  TClientProtocol = class(TNetProtocol)
  private
    procedure SendListHashes;
    function ListHashesMatched: Boolean;
    ...
  public
    procedure RunExchange; override;
  end;

implementation

uses
  Sync.Packets;

procedure TClientProtocol.RunExchange;
begin
  inherited;

  ...

  // 3. Обмен изменениями

  SendListHashes;
  if ListHashesMatched then // Конец синхронизации?
    ... // Да - прерываем выполнение.
  else
    ... // Нет - дальнейшие шаги протокола.
end;

procedure TClientProtocol.SendListHashes;
var
  ListHashesPacket: TListHashesPacket;
begin
  ListHashesPacket := TListHashesPacket.Create(FTransport);
  try
    // Заполнение ListHashesPacket.Hashes данными из БД.
    ...
    ListHashesPacket.Send;
  finally
    ListHashesPacket.Free;
  end;
end;

function TClientProtocol.ListHashesMatched: Boolean;
var
  ListHashesResponsePacket: TListHashesResponsePacket;
begin
  ListHashesResponsePacket := TListHashesResponsePacket.Create(FTransport);
  try
    ListHashesResponsePacket.Receive;
    Result := ListHashesResponsePacket.HashesMatched;
  finally
    ListHashesResponsePacket.Free;
  end;
end;

end.

unit Sync.Protocol.Server;

interface

uses
  Net.Protocol;

type
  TServerProtocol = class(TNetProtocol)
  private
    function ListHashesMatched: Boolean;
    ...
  public
    procedure RunExchange; override;
  end;

implementation

uses
  Sync.Packets;

procedure TServerProtocol.RunExchange;
begin
  inherited;

  ...

  // 3. Обмен изменениями

  if ListHashesMatched then // Конец синхронизации?
    ... // Да - прерываем выполнение.
  else
    ... // Нет - дальнейшие шаги протокола.
end;

function TServerProtocol.ListHashesMatched: Boolean;
var
  ClientListHashesPacket: TListHashesPacket;
  ListHashesResponsePacket: TListHashesResponsePacket;
begin
  ClientListHashesPacket := TListHashesPacket.Create(FTransport);
  try
    ClientListHashesPacket.Receive;

    ListHashesResponsePacket := TListHashesResponsePacket.Create(FTransport);
    try
      // Сравнение ClientListHashesPacket.Hashes с хешами в БД,
      // заполнение ListHashesResponsePacket.HashesMatched.
      ...
      ListHashesResponsePacket.Send;

      Result := ListHashesResponsePacket.HashesMatched;
    finally
      ListHashesResponsePacket.Free;
    end;
  finally
    ClientListHashesPacket.Free;
  end;
end;

end.

Финальный вариант

Данные

// Заполнение ListHashesPacket.Hashes данными из БД.
...
ListHashesPacket.Send;

// Сравнение ClientListHashesPacket.Hashes с хешами в БД,
// заполнение ListHashesResponsePacket.HashesMatched.
...
ListHashesResponsePacket.Send;

unit Sync.DB;

interface

uses
  FireDAC.Comp.Client;

type
  TDBFacade = class abstract
  protected
    FConnection: TFDConnection;
  public
    constructor Create;
    destructor Destroy; override;

    procedure StartTransaction;
    procedure CommitTransaction;
    procedure RollbackTransaction;
  end;

implementation

constructor TDBFacade.Create;
begin
  FConnection := TFDConnection.Create(nil);
end;

destructor TDBFacade.Destroy;
begin
  FConnection.Free;

  inherited;
end;

procedure TDBFacade.StartTransaction;
begin
  FConnection.StartTransaction;
end;

procedure TDBFacade.CommitTransaction;
begin
  FConnection.Commit;
end;

procedure TDBFacade.RollbackTransaction;
begin
  FConnection.Rollback;
end;

end.

unit Sync.DB.Client;

interface

uses
  Sync.DB, Sync.Packets;

type
  TClientDBFacade = class(TDBFacade)
  public
    procedure CalcListHashes(const Hashes: TListHashesPacket.TListHashes);
    ...
  end;

implementation

uses
  FireDAC.Comp.Client;

procedure TClientDBFacade.CalcListHashes(const Hashes: TListHashesPacket.TListHashes);
var
  StoredProcHashes: TFDStoredProc;
begin
  StoredProcHashes := TFDStoredProc.Create(nil);
  try
    // Инициализация StoredProcHashes.
    ...
    StoredProcHashes.Open;

    while not StoredProcHashes.Eof do
    begin
      // Заполнение Hashes.
      ...
      StoredProcHashes.Next;
    end;
  finally
    StoredProcHashes.Free;
  end;
end;

end.

unit Sync.DB.Server;

interface

uses
  Sync.DB, Sync.Packets;

type
  TServerDBFacade = class(TDBFacade)
  public
    function CompareListHashes(const ClientHashes: TListHashesPacket.TListHashes): Boolean;
    ...
  end;

implementation

uses
  FireDAC.Comp.Client;

function TServerDBFacade.CompareListHashes(const ClientHashes: TListHashesPacket.TListHashes): Boolean;
var
  StoredProcHashes: TFDStoredProc;
begin
  Result := True;

  StoredProcHashes := TFDStoredProc.Create(nil);
  try
    // Инициализация StoredProcHashes.
    ...
    StoredProcHashes.Open; // Получение серверных хешей.

    while not StoredProcHashes.Eof do
    begin
      Result := Result and {Текущий серверный хеш совпадает с клиентским из ClientHashes?};
      StoredProcHashes.Next;
    end;
  finally
    StoredProcHashes.Free;
  end;
end;

end.

procedure TClientSyncDBFacade.CalcListHashes(const Hashes: TListHashesPacket.THashesCollection);
var
  Lists: TList<TLocalListID>;

  procedure PrepareListsToHashing;
  begin
    PrepareStoredProcedureToWork(SyncPrepareListsToHashingProcedure);

    FStoredProcedure.Open;

    while not FStoredProcedure.Eof do
    begin
      Lists.Add( FStoredProcedure['LIST_ID'] );
      FStoredProcedure.Next;
    end;
  end;

  procedure CalcTotalChildHashes;
  var
    ListID: TLocalListID;
    TotalUsersHash, TotalItemsHash: TMD5Hash;
  begin
    for ListID in Lists do
    begin
      PrepareStoredProcedureToWork(SyncSelectListUsersForHashingProcedure);
      FStoredProcedure.ParamByName('LIST_ID').Value := ListID;
      TotalUsersHash := CalcTotalHashAsBytes( FStoredProcedure, ['USER_AS_STRING'] );

      PrepareStoredProcedureToWork(SyncSelectListItemAndItemMessagesHashProcedure);
      FStoredProcedure.ParamByName('LIST_ID').Value := ListID;
      TotalItemsHash := CalcTotalHashAsBytes( FStoredProcedure, ['ITEM_HASH', 'ITEM_MESSAGES_HASH'] );

      PrepareStoredProcedureToWork(SyncAddTotalListHashesProcedure);
      FStoredProcedure.ParamByName('LIST_ID').Value := ListID;
      FStoredProcedure.ParamByName('TOTAL_USERS_HASH').AsHash := TotalUsersHash;
      FStoredProcedure.ParamByName('TOTAL_ITEMS_HASH').AsHash := TotalItemsHash;
      FStoredProcedure.ExecProc;
    end;
  end;

  procedure FillHashes;
  var
    ListHashes: TListHashesPacket.THashes;
  begin
    PrepareStoredProcedureToWork(SyncSelectListHashesProcedure);

    FStoredProcedure.Open;

    while not FStoredProcedure.Eof do
    begin
      ListHashes := TListHashesPacket.THashes.Create;
      try
        ListHashes.Hash := HashToString( FStoredProcedure.FieldByName('LIST_HASH').AsHash );
        ListHashes.UsersHash := HashToString( FStoredProcedure.FieldByName('LIST_USERS_HASH').AsHash );
        ListHashes.ItemsHash := HashToString( FStoredProcedure.FieldByName('LIST_ITEMS_HASH').AsHash );
      except
        ListHashes.DisposeOf;
        raise;
      end;

      Hashes.Add( FStoredProcedure.FieldByName('LIST_GLOBAL_ID').AsUUID, ListHashes );

      FStoredProcedure.Next;
    end;
  end;

begin
  Lists := TList<TLocalListID>.Create;
  try
    PrepareListsToHashing;

    CalcRecordHashes(TListHashes);
    CalcRecordHashes(TListItemHashes);
    CalcRecordHashes(TListItemMessagesHashes);
    CalcTotalChildHashes;

    FillHashes;
  finally
    Lists.DisposeOf;
  end;
end;

Окончательный вид протокола

unit Sync.Protocol.Client;

interface

uses
  Net.Protocol, Sync.DB.Client;

type
  TClientProtocol = class(TNetProtocol)
  private
    FDBFacade: TClientDBFacade;

    procedure SendListHashes;
    ...
  public
    procedure RunExchange; override;
  end;

implementation

uses
  Sync.Packets;

procedure TClientProtocol.RunExchange;
begin
  inherited;

  FDBFacade.StartTransaction;
  try
    ...

    // 3. Обмен изменениями

    SendListHashes;
    if ListHashesMatched then // Конец синхронизации?
      ... // Да - прерываем выполнение.
    else
      ... // Нет - дальнейшие шаги протокола.

    FDBFacade.CommitTransaction;
  except
    FDBFacade.RollbackTransaction;
    raise;
  end;
end;

procedure TClientProtocol.SendListHashes;
var
  ListHashesPacket: TListHashesPacket;
begin
  ListHashesPacket := TListHashesPacket.Create(FTransport);
  try
    FDBFacade.CalcListHashes(ListHashesPacket.Hashes);
    ListHashesPacket.Send;
  finally
    ListHashesPacket.Free;
  end;
end;

...

end.

unit Sync.Protocol.Server;

interface

uses
  Net.Protocol, Sync.DB.Server;

type
  TServerProtocol = class(TNetProtocol)
  private
    FDBFacade: TServerDBFacade;

    function ListHashesMatched: Boolean;
    ...
  public
    procedure RunExchange; override;
  end;

implementation

uses
  Sync.Packets;

procedure TServerProtocol.RunExchange;
begin
  inherited;

  FDBFacade.StartTransaction;
  try
    ...

    // 3. Обмен изменениями

    if ListHashesMatched then // Конец синхронизации?
      ... // Да - прерываем выполнение.
    else
      ... // Нет - дальнейшие шаги протокола.

    FDBFacade.CommitTransaction;
  except
    FDBFacade.RollbackTransaction;
    raise;
  end;
end;

function TServerProtocol.ListHashesMatched: Boolean;
var
  ClientListHashesPacket: TListHashesPacket;
  ListHashesResponsePacket: TListHashesResponsePacket;
begin
  ClientListHashesPacket := TListHashesPacket.Create(FTransport);
  try
    ClientListHashesPacket.Receive;

    ListHashesResponsePacket := TListHashesResponsePacket.Create(FTransport);
    try
      ListHashesResponsePacket.HashesMatched := FDBFacade.CompareListHashes(ClientListHashesPacket.Hashes);
      ListHashesResponsePacket.Send;

      Result := ListHashesResponsePacket.HashesMatched;
    finally
      ListHashesResponsePacket.Free;
    end;
  finally
    ClientListHashesPacket.Free;
  end;
end;

end.

Доработка пакета

• сначала необходимо упаковать (сериализовать) данные в вид, подходящий к передаче по сети;
• затем следует выполнить физическую отправку упакованного.

unit Net.Packet;

interface

uses
  Net.Protocol, System.JSON;

type
  TPacket = class abstract
  ...
  private
    function PackToJSON: TJSONObject;
    procedure UnpackFromJSON(const JSON: TJSONObject);
  ...
  end;

TListPacket = class(TStreamPacket)
public
  type
    TPhoto = class(TPackableObject)
    strict private
      FSortOrder: Int16;
      FItemMessageID: TItemMessageID;
    public
      property ItemMessageID: TItemMessageID read FItemMessageID write FItemMessageID;
      property SortOrder: Int16 read FSortOrder write FSortOrder;
    end;

    TPhotos = TStandardPacket.TPackableObjectDictionary<TMessagePhotoID, TPhoto>;

    TMessage = class(TPackableObject)
    strict private
      FAuthor: TUserID;
      FAddDate: TDateTime;
      FText: string;
      FListItemID: TListItemID;
    public
      property ListItemID: TListItemID read FListItemID write FListItemID;
      property Author: TUserID read FAuthor write FAuthor;
      property AddDate: TDateTime read FAddDate write FAddDate;
      property Text: string read FText write FText;
    end;

    TMessages = TStandardPacket.TPackableObjectDictionary<TItemMessageID, TMessage>;

    TListDescendant = class(TPackableObject)
    strict private
      FListID: TListID;
    public
      property ListID: TListID read FListID write FListID;
    end;

    TItem = class(TListDescendant)
    strict private
      FAddDate: TDateTime;
      FAmount: TAmount;
      FEstimatedPrice: Currency;
      FExactPrice: Currency;
      FStandardGoods: TID;
      FInTrash: Boolean;
      FUnitOfMeasurement: TID;
      FStrikeoutDate: TDateTime;
      FCustomGoods: TGoodsID;
    public
      property StandardGoods: TID read FStandardGoods write FStandardGoods;
      property CustomGoods: TGoodsID read FCustomGoods write FCustomGoods;
      property Amount: TAmount read FAmount write FAmount;
      property UnitOfMeasurement: TID read FUnitOfMeasurement write FUnitOfMeasurement;
      property EstimatedPrice: Currency read FEstimatedPrice write FEstimatedPrice;
      property ExactPrice: Currency read FExactPrice write FExactPrice;
      property AddDate: TDateTime read FAddDate write FAddDate;
      property StrikeoutDate: TDateTime read FStrikeoutDate write FStrikeoutDate;
      property InTrash: Boolean read FInTrash write FInTrash;
    end;

    TItems = TStandardPacket.TPackableObjectDictionary<TListItemID, TItem>;

    TUser = class(TListDescendant)
    strict private
      FUserID: TUserID;
    public
      property UserID: TUserID read FUserID write FUserID;
    end;

    TUsers = TStandardPacket.TPackableObjectList<TUser>;

    TList = class(TPackableObject)
    strict private
      FName: string;
      FAuthor: TUserID;
      FAddDate: TDateTime;
      FDeadline: TDate;
      FInTrash: Boolean;
    public
      property Author: TUserID read FAuthor write FAuthor;
      property Name: string read FName write FName;
      property AddDate: TDateTime read FAddDate write FAddDate;
      property Deadline: TDate read FDeadline write FDeadline;
      property InTrash: Boolean read FInTrash write FInTrash;
    end;

    TLists = TStandardPacket.TPackableObjectDictionary<TListID, TList>;
private
  FLists: TLists;
  FMessages: TMessages;
  FItems: TItems;
  FUsers: TUsers;
  FPhotos: TPhotos;
public
  property Lists: TLists read FLists write FLists;
  property Users: TUsers read FUsers write FUsers;
  property Items: TItems read FItems write FItems;
  property Messages: TMessages read FMessages write FMessages;
  property Photos: TPhotos read FPhotos write SetPhotos;
end;

{
  16:
  {
    Hash: "d0860029f1400147deef86d3246d29a4",
    UsersHash: "77febf816dac209a22880c313ffae6ad",
    ItemsHash: "1679091c5a880faf6fb5e6087eb1b2dc"
  },
  38:
  {
    Hash: "81c8061686c10875781a2b37c398c6ab",
    UsersHash: "d3556bff1785e082b1508bb4e611c012",
    ItemsHash: "0e3a37aa85a14e359df74fa77eded3f6"
  }
}

unit Net.Packet;

interface

...

implementation

uses
  System.SysUtils, IdGlobal;

...

procedure TPacket.Send;
var
  DataLength: Integer;
  RawData: TBytes;
  JSON: TJSONObject;
begin
  FTransport.Write(Kind);

  JSON := PackToJSON;
  try
    SetLength(RawData, JSON.EstimatedByteSize);
    DataLength := JSON.ToBytes( RawData, Low(RawData) );

    FTransport.Write(DataLength);
    FTransport.Write( TIdBytes(RawData), DataLength );
  finally
    JSON.Free;
  end;
end;

procedure TPacket.Receive;
var
  ActualKind: TPacketKind;

  DataLength: Integer;
  RawData: TBytes;
  JSON: TJSONObject;
begin
  ActualKind := FTransport.ReadUInt16;

  if Kind <> ActualKind then
    // Реакция на неожидаемый пакет.
    ...

  DataLength := FTransport.ReadInt32;
  FTransport.ReadBytes( TIdBytes(RawData), DataLength, False );

  JSON := TJSONObject.Create;
  try
    JSON.Parse(RawData, 0);
    UnpackFromJSON(JSON);
  finally
    JSON.Free;
  end;
end;

...

end.

Заключение