mORMot Open Source

  IMyInterface=interface(ICQRSService)
    [some guid here]
    ...
    function GetData(out aDataArray: TDataObjArray): TCQRSResult;
    ...
  end;

      case ValueType of
      smvRawUTF8..smvWideString:
        Include(ValueKindAsm,vIsString);
      smvDynArray:
        if ObjArraySerializers.Find(ArgTypeInfo)<>nil then
          Include(ValueKindAsm,vIsObjArray);

function TObjectListPropertyHashed.IndexOf(aObject: TObject): integer;
begin
  if fCount>0 then
    if fHashed then begin
      if not fHashValid then
        IntHashValid;
      result := fHash.HashFind(fHash.fHashElement(aObject,fHash.fHasher),PtrInt(aObject));
      if result>=0 then
        exit; // if found
    end else
    for result := 0 to fCount-1 do
      if IntComp(fList[result],aObject)=0 then
        exit;
  result := -1;
end;

function TObjectListPropertyHashed.Add(aObject: TObject; out wasAdded: boolean): integer;
begin
  wasAdded := false;
  if self<>nil then
    if fHashed then begin
      if not fHashValid then    // <- That's the problem, fHashValid is true but we need to rehash
        IntHashValid;
      result := fHash.FindHashedForAdding(aObject,wasAdded,
        fHash.fHashElement(aObject,fHash.fHasher));
      if wasAdded then
        fList[result] := aObject;
    end else begin
      for result := 0 to fCount-1 do
        if IntComp(fList[result],aObject)=0 then
          exit;
      wasAdded := true;
      result := fHash.Add(aObject);
      if fCount>=TOBJECTLISTHASHED_START_HASHING_COUNT then
        fHashed := true;
    end
  else
    result := -1;
end;

function TObjectListPropertyHashed.Add(aObject: TObject; out wasAdded: boolean): integer;
begin
  wasAdded := false;
  if self<>nil then
    if fHashed then begin
      IntHashValid;  // "fHashValid:=false;" instead of "IntHashValid;" works too because the next .IndexOf() call is forced to rehash the list then.
      result := fHash.FindHashedForAdding(aObject,wasAdded,
        fHash.fHashElement(aObject,fHash.fHasher));
      if wasAdded then
        fList[result] := aObject;
    end else begin
      for result := 0 to fCount-1 do
        if IntComp(fList[result],aObject)=0 then
          exit;
      wasAdded := true;
      result := fHash.Add(aObject);
      if fCount>=TOBJECTLISTHASHED_START_HASHING_COUNT then
        fHashed := true;
    end
  else
    result := -1;
end;

procedure TDynArrayHashed.HashAdd(const Elem; aHashCode: Cardinal; var result: integer);
var n,cap: integer;
begin
  n := Count;
  SetCount(n+1); // reserve space for a void element in array
  cap := Capacity;
  if cap*2-cap shr 3>=fHashsCount then begin
    // fHashs[] is too small -> recreate
    ReHash;
    result := HashFind(aHashCode,Elem); // fHashs[] has changed -> recompute
    assert(result<0);
  end;
  with fHashs[-result-1] do begin // HashFind returned negative index in fHashs[]
    Hash := aHashCode;
    Index := n;
  end;
  result := n;
end;

TDynArrayHashed.HashAdd((kein Wert),1313814477,0)
TDynArrayHashed.FindHashedForAdding((kein Wert),True,1313814477)
TDynArrayHashed.AddAndMakeUniqueName('EMAIL')
TSQLDBZEOSStatement.ExecutePrepared
TSQLDBConnectionProperties.Execute('SELECT cd.Email from ContactData CD where cd.ContactDataID IN (SELECT lcp.ContactDataID from LinkCustomerPerson lcp WHERE lcp.CustomerID=?)',(...),nil,False)
...

--------------------------------2016/9/22 12:22:13--------------------------------
A memory block has been leaked. The size is: 2244

This block was allocated by thread 0x18B8, and the stack trace (return addresses) at the time was:
403101 [system.pas][System][@ReallocMem][2550]
40752C [system.pas][System][DynArraySetLength][16060]
40760E [system.pas][System][@DynArraySetLength][16108]
461AF2 [SynCommons.pas][SynCommons][TDynArrayHashed.ReHash][44383]
460E2B [SynCommons.pas][SynCommons][TDynArrayHashed.Scan][43871]
460F5A [SynCommons.pas][SynCommons][TDynArrayHashed.HashAdd][43905]
461073 [SynCommons.pas][SynCommons][TDynArrayHashed.FindHashedForAdding][43943]
4610D1 [SynCommons.pas][SynCommons][TDynArrayHashed.AddAndMakeUniqueName][43955]
AD761E [ZDbcResultSetMetadata.pas][ZDbcResultSetMetadata][TZAbstractResultSetMetadata.GetColumnType][474]
B9CF92 [SynDBZeos.pas][SynDBZeos][TSQLDBZEOSStatement.ExecutePrepared][1113]
AA7233 [SynDB.pas][SynDB][TSQLDBConnectionPropertiesThreadSafe.ThreadSafeConnection][6438]

The block is currently used for an object of class: Unknown

The allocation number is: 127937

Current memory dump of 256 bytes starting at pointer address 7EBA8590:
CC 37 4F 4E 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
Ì  7  O  N  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .

procedure ObjectToJSONFile(Value: TObject; const JSONFile: TFileName;
  Options: TTextWriterWriteObjectOptions);
var humanread: boolean;
    json: RawUTF8;
begin
  humanread := woHumanReadable in Options; 
  Exclude(Options,woHumanReadable);
  json := ObjectToJSON(Value,Options);
  if humanread then
    // woHumanReadable not working with custom JSON serializers, e.g. T*ObjArray
    JSONBufferReformatToFile(pointer(json),JSONFile) else
    FileFromString(json,JSONFile);
end;

function ObjectToJSONFile(Value: TObject; const JSONFile: TFileName;
  Options: TTextWriterWriteObjectOptions): boolean;
var humanread: boolean;
    json: RawUTF8;
begin
  humanread := woHumanReadable in Options; 
  Exclude(Options,woHumanReadable);
  json := ObjectToJSON(Value,Options);
  if humanread then
    // woHumanReadable not working with custom JSON serializers, e.g. T*ObjArray
    result:=JSONBufferReformatToFile(pointer(json),JSONFile) else
    result:=FileFromString(json,JSONFile);
end;

type
  TPerson=class(TSynPersistent)
  private
    fFullName: RawUTF8;
  published
    property FullName: RawUTF8 read fFullName write fFullName;
  end;
  TPersonObjArray=array of TPerson;

procedure TTestDynArray.DynArrayDelete;
var
  DA: TDynArray;
  arrPerson: TPersonObjArray;
  i: integer;
  person: TPerson;
const
  cMax=3;
begin
  TJSONSerializer.RegisterObjArrayForJSON([TypeInfo(TPersonObjArray),TPerson]);
  DA.Init(TypeInfo(TPersonObjArray), arrPerson);
  for i:=1 to cMax do
  begin
    person:=TPerson.Create;
    person.FullName:=FormatUTF8('FullName-%',[(i)]);
    DA.Add(person);
  end;
  for i:=Low(arrPerson) to High(arrPerson) do
  begin
    person:=arrPerson[(i)];
    Check(person.FullName=FormatUTF8('FullName-%',[(i+1)]));
  end;
  DA.Delete(0);
  for i:=Low(arrPerson) to High(arrPerson) do
  begin
    person:=arrPerson[(i)];
    Check(person.FullName=FormatUTF8('FullName-%',[(i+2)]));              // BOOM!!! -> access violation 
  end;
  DA.Clear;
end;

procedure TDynArray.Delete(aIndex: Integer);
var n, len: integer;
    P: PAnsiChar;
begin
  if fValue=nil then
    exit; // avoid GPF if void
  n := Count;
  if cardinal(aIndex)>=cardinal(n) then
    exit; // out of range
  dec(n);
  P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize);
  if ElemType<>nil then
    _Finalize(P,ElemType) else
    if GetIsObjArray then
      FreeAndNil(PObject(P)^);                  // <- The TPerson object is destroyed here
  if n>aIndex then begin
    len := cardinal(n-aIndex)*ElemSize;
    MoveFast(P[ElemSize],P[0],len);
    if ElemType<>nil then // avoid GPF
      FillcharFast(P[len],ElemSize,0);
  end;
  SetCount(n);                                  // <- this leads to the issue...
end;

procedure TDynArray.SetCount(aCount: integer);
.
.
.
      end else
      if aCount>0 then // aCount=0 should release memory (e.g. TDynArray.Clear)
        // size-down -> only if worth it (for faster Delete)
        if (capa<=MINIMUM_SIZE) or (capa-aCount<capa shr 3) then
          exit;
    end;
  end;
  // no external Count, array size-down or array up-grow -> realloc
  InternalSetLength(aCount);           // <- this leads to the issue...
end;

procedure TDynArray.InternalSetLength(NewLength: PtrUInt);
var p: PDynArrayRec;
    pa: PAnsiChar absolute p;
    OldLength, NeededSize, minLength: PtrUInt;
    pp: pointer;
    i: integer;
begin // this method is faster than default System.DynArraySetLength() function
  // check that new array length is not just a hidden finalize
  if NewLength=0 then begin
    {$ifndef NOVARIANTS} // faster clear of custom variant uniformous array
    if ArrayType=TypeInfo(TVariantDynArray) then begin
      VariantDynArrayClear(TVariantDynArray(fValue^));
      exit;
    end;
    {$endif}
    if GetIsObjArray then
      for i := 0 to Count-1 do
        PObjectArray(fValue^)^[(i)].Free;
    _DynArrayClear(fValue^,ArrayType);
    exit;
  end;
  // retrieve old length
  p := fValue^;
  if p<>nil then begin
    dec(PtrUInt(p),Sizeof(TDynArrayRec)); // p^ = start of heap object
    OldLength := p^.length;
  end else
    OldLength := 0;
  // calculate the needed size of the resulting memory structure on heap
  NeededSize := NewLength*ElemSize+Sizeof(TDynArrayRec);
  if NeededSize>1024*1024*512 then // max allowed memory block is 512MB
    raise ERangeError.CreateFmt('TDynArray SetLength(%s,%d) size concern',
      [PShortString(@PDynArrayTypeInfo(ArrayType).NameLen)^,NewLength]);
  // if not shared (refCnt=1), resize; if shared, create copy (not thread safe)
  if (p=nil) or (p^.refCnt=1) then begin
    if NewLength<OldLength then
      if ElemType<>nil then
        _FinalizeArray(pa+NeededSize,ElemType,OldLength-NewLength) else
        if GetIsObjArray then
          for i := NewLength to OldLength-1 do
            PObjectArray(fValue^)^[(i)].Free;                // <- the TPerson object is destroyed another time. Without this call everything works as expeced.
    ReallocMem(p,neededSize);
  end else begin
    InterlockedDecrement(PInteger(@p^.refCnt)^); // FPC has refCnt: PtrInt
    GetMem(p,neededSize);
    minLength := oldLength;
    if minLength>newLength then
      minLength := newLength;
    if ElemType<>nil then begin
      pp := pa+Sizeof(TDynArrayRec);
      FillcharFast(pp^,minLength*elemSize,0);
      CopyArray(pp,fValue^,ElemType,minLength)
    end else
      MoveFast(fValue^,pa[Sizeof(TDynArrayRec)],minLength*elemSize);
  end;
  // set refCnt=1 and new length to the heap memory structure
  with p^ do begin
    refCnt := 1;
    {$ifdef FPC}
    high := newLength-1;
    {$else}
    length := newLength;
    {$endif}
  end;
  Inc(PtrUInt(p),Sizeof(p^));
  // reset new allocated elements content to zero
  if NewLength>OldLength then begin
    OldLength := OldLength*elemSize;
    FillcharFast(pa[OldLength],neededSize-OldLength-Sizeof(TDynArrayRec),0);
  end;
  fValue^ := p;
end;

type
  TSQLPushNotification=class(TSQLRecord)
  published
    property PushToSessionID: TSessionID;  // Session ID this notification is meant for
    property JsonData: TJsonData; // The data object
  end;

program mORMotBug;

{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER

{$APPTYPE CONSOLE}

{$R *.res}

uses
  FastMM4,
  SysUtils,
  Classes,
  Windows,
  SynSqlite3Static,
  SynSqlite3,
  SynCommons,
  SynLog,
  SynTests,
  mORMot,
  mORMotHttpServer,
  mORMotHttpClient,
  mORMotSqlite3,
  mORMotDDD;

const
  /// "FORCE_BUG = true;" will send WebSocket notifications to the other connected clients in IMyCommand.Add() method.
  // At some point there will happen an ESynCrypto Exception: 'TAESCFB.DecryptPKCS7: Invalid content'!
  // The Websocket bug will occur. "FORCE_BUG = false;" won't produce any issues.
  FORCE_BUG = true;

  HTTP_PORT = '80';
  WEBSOCKET_KEY = 'key';

type
  ICallback = interface(IInvokable)
    ['{B42B0BBA-AA9C-459B-8731-1C52441361C9}']
    procedure DoCallback(const aDescription: RawUTF8);
  end;

var
  gCallbackArray: array of ICallback;
  gCriticalSection: TRTLCriticalSection;

type
  TCallback = class(TInterfacedObject, ICallback)
  public
    procedure DoCallback(const aDescription: RawUTF8);
  end;


  // This is our simple Test data class. Will be mapped to TSQLRecordTest.
  TTest = class(TSynPersistent)
  private
    fDescription: RawUTF8;
  published
    property Description: RawUTF8 read fDescription write fDescription;
  end;
  TTestObjArray = array of TTest;

  // The corresponding TSQLRecord for TTest.
  TSQLRecordTest = class(TSQLRecord)
  private
    fDescription: RawUTF8;
  published
    property Description: RawUTF8 read fDescription write fDescription;
  end;

  // CQRS Query Interface fo TTest
  IMyQuery = interface(ICQRSService)
    ['{DD402806-39C2-4921-98AA-A575DD1117D6}']
    function SelectByDescription(const aDescription: RawUTF8): TCQRSResult;
    function SelectAll: TCQRSResult;
    function Get(out aAggregate: TTest): TCQRSResult;
    function GetAll(out aAggregates: TTestObjArray): TCQRSResult;
    function GetNext(out aAggregate: TTest): TCQRSResult;
    function GetCount: integer;
  end;

  // CQRS Command Interface for TTest
  IMyCommand = interface(IMyQuery)
    ['{F0E4C64C-B43A-491B-85E9-FD136843BFCB}']
    function Add(const aAggregate: TTest): TCQRSResult;
    function Update(const aUpdatedAggregate: TTest): TCQRSResult;
    function Delete: TCQRSResult;
    function DeleteAll: TCQRSResult;
    function Commit: TCQRSResult;
    function Rollback: TCQRSResult;
    function RegisterCallback(const aInterface: ICallback): TCQRSResult;
  end;

  // The infratructure REST class implementing the Query and Command Interfaces for TTest
  TTestRest = class(TDDDRepositoryRestCommand,IMyCommand,IMyQuery)
  public
    function SelectByDescription(const aDescription: RawUTF8): TCQRSResult;
    function SelectAll: TCQRSResult;
    function Get(out aAggregate: TTest): TCQRSResult;
    function GetAll(out aAggregates: TTestObjArray): TCQRSResult;
    function GetNext(out aAggregate: TTest): TCQRSResult;
    function Add(const aAggregate: TTest): TCQRSResult;
    function Update(const aUpdatedAggregate: TTest): TCQRSResult;
    function RegisterCallback(const aInterface: ICallback): TCQRSResult;
  end;

  // REST Factory for TTestRest instances
  TTestRestFactory = class(TDDDRepositoryRestFactory)
  public
    constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager=nil); reintroduce;
  end;

  // Test container
  TMyTests = class(TSynTestsLogged)
  published
    procedure MyTests;
  end;

  // Test case doing the actual work
  TMyTestCase = class(TSynTestCase)
  private
    // Rest server
    fRestServer: TSQLRestServerDB;
    // Http server
    fHttpServer: TSQLHttpServer;
    /// Will create as many Clients as specified by aClient.
    // - Each client will perform as many Requests as specified by aRequests.
    // - This function will wait for all Clients until finished.
    function ClientTest(const aClients, aRequests: integer):boolean;
  protected
    // Cleaning up the test
    procedure CleanUp; override;
  published
    // Delete any old Test database on start
    procedure DeleteOldDatabase;
    // Start the whole DDD Server (http and rest)
    procedure StartServer;
    // Test straight-forward access using 1 thread and 1 client
    procedure SingleClientTest;
    // Test concurrent access with multiple clients. This will crash!
    procedure MultiClientTest;
  end;

  // Custom TSQLHttpClient encapsulating the remote IMyCommand interface.
  TMyHttpClient=class(TSQLHttpClientWebsockets)
  private
    // Internal Model
    fModel: TSQLModel;
    // IMyCommand interface. Will be assigned inside SetUser
    fMyCommand: IMyCommand;
    fCallback: ICallback;
  public
    constructor Create(const aServer,aPort: RawUTF8); //overload;
    destructor Destroy; override;
    function SetUser(const aUserName, aPassword: RawUTF8; aHashedPassword: Boolean=false): boolean; reintroduce;
    property MyCommand: IMyCommand read fMyCommand;
  end;

  // The thread used by TMyTestCase.ClientTest
  TMyThread = class(TThread)
  private
    fHttpClient: TMyHttpClient;
    fRequestCount: integer;
    fId: integer;
    fIsError: boolean;
  protected
    procedure Execute; override;
  public
    constructor Create(const aId, aRequestCount: integer);
    destructor Destroy; override;
    property IsError: boolean read fIsError;
  end;

{ TTestRest }

function TTestRest.SelectByDescription(
  const aDescription: RawUTF8): TCQRSResult;
begin
  result := ORMSelectOne('Description=?',[aDescription],(aDescription=''));
end;

function TTestRest.SelectAll: TCQRSResult;
begin
  result := ORMSelectAll('',[]);
end;

function TTestRest.Get(out aAggregate: TTest): TCQRSResult;
begin
  result := ORMGetAggregate(aAggregate);
end;

function TTestRest.GetAll(
  out aAggregates: TTestObjArray): TCQRSResult;
begin
  result := ORMGetAllAggregates(aAggregates);
end;

function TTestRest.GetNext(out aAggregate: TTest): TCQRSResult;
begin
  result := ORMGetNextAggregate(aAggregate);
end;

function TTestRest.Add(const aAggregate: TTest): TCQRSResult;
var
  i: integer;
begin
  result := ORMAdd(aAggregate);
  if not FORCE_BUG then
    exit;
  EnterCriticalSection(gCriticalSection);
  try
    for i := high(gCallbackArray) downto 0 do // downwards for InterfaceArrayDelete()
      try
        gCallbackArray[i].DoCallback('');
      except
        InterfaceArrayDelete(gCallbackArray,i); // unsubscribe the callback on failure
      end;
  finally
    LeaveCriticalSection(gCriticalSection);
  end;
end;

function TTestRest.Update(
  const aUpdatedAggregate: TTest): TCQRSResult;
begin
  result := ORMUpdate(aUpdatedAggregate);
end;


{ TInfraRepoUserFactory }

constructor TTestRestFactory.Create(aRest: TSQLRest;
  aOwner: TDDDRepositoryRestManager);
begin
  inherited Create(IMyCommand,TTestRest,TTest,aRest,TSQLRecordTest,aOwner);
end;

function TTestRest.RegisterCallback(
  const aInterface: ICallback): TCQRSResult;
begin
  EnterCriticalSection(gCriticalSection);
  try
    InterfaceArrayAdd(gCallbackArray, aInterface);
  finally
    LeaveCriticalSection(gCriticalSection);
  end;
  result:=cqrsSuccess;
end;

{ TMyTests }

procedure TMyTests.MyTests;
begin
  AddCase([TMyTestCase]);
end;

{ TMyTestCase }

procedure TMyTestCase.CleanUp;
var
  i: integer;
begin
  EnterCriticalSection(gCriticalSection);
  try
    for i:=High(gCallbackArray) downto 0 do
      InterfaceArrayDelete(gCallbackArray, i);
  finally
    LeaveCriticalSection(gCriticalSection);
  end;
  if Assigned(fHttpServer) then
    FreeAndNil(fHttpServer);
  if Assigned(fRestServer) then
    FreeAndNil(fRestServer);
end;

procedure TMyTestCase.DeleteOldDatabase;
begin
  if FileExists(ChangeFileExt(ParamStr(0), '.db3')) then
    SysUtils.DeleteFile(ChangeFileExt(ParamStr(0), '.db3'));
  CheckNot(FileExists(ChangeFileExt(ParamStr(0), '.db3')));
end;

procedure TMyTestCase.StartServer;
begin
  fRestServer:=TSQLRestServerDB.CreateWithOwnModel([TSQLRecordTest], ChangeFileExt(ParamStr(0), '.db3'), true);
  with fRestServer do begin
      DB.Synchronous := smNormal;
      DB.LockingMode := lmExclusive;
      CreateMissingTables();
      TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyQuery),TypeInfo(IMyCommand)]);
      ServiceContainer.InjectResolver([TTestRestFactory.Create(fRestServer)],true);
      ServiceDefine(TTestRest,[IMyCommand],sicClientDriven);
    end;
  fHttpServer:=TSQLHttpServer.Create(HTTP_PORT, fRestServer, '+', useBidirSocket);
  fHttpServer.WebSocketsEnable(fRestServer, WEBSOCKET_KEY);
end;

procedure TMyTestCase.MultiClientTest;
begin
  ClientTest(20,50);
end;

procedure TMyTestCase.SingleClientTest;
var
  HttpClient: TMyHttpClient;
  test: TTest;
  i: integer;
const
  MAX = 1000;
begin
  HttpClient:=TMyHttpClient.Create('localhost', HTTP_PORT);
  try
    Check(HttpClient.SetUser('Admin', 'synopse'));
    test:=TTest.Create;
    try
      for i:=0 to MAX-1 do begin
        test.Description:=FormatUTF8('test-%',[i]);
        Check(HttpClient.MyCommand.Add(test)=cqrsSuccess);
      end;
      Check(HttpClient.MyCommand.Commit=cqrsSuccess);
    finally
      test.Free;
    end;
  finally
    HttpClient.Free;
  end;
end;

function TMyTestCase.ClientTest(const aClients, aRequests: integer):boolean;
var
  i: integer;
  arrThreads: array of TMyThread;
  arrHandles: array of THandle;
  rWait: Cardinal;
begin
  result := false;
  SetLength(arrThreads, aClients);
  SetLength(arrHandles, aClients);
  for i:=Low(arrThreads) to High(arrThreads) do
  begin
    arrThreads[i]:=TMyThread.Create(i,aRequests);
    arrHandles[i]:=arrThreads[i].Handle;
    arrThreads[i].Resume;
  end;
  try
    repeat
      rWait:= WaitForMultipleObjects(aClients, @arrHandles[0], True, INFINITE);
    until rWait<>WAIT_TIMEOUT;
  finally
    for i:=Low(arrThreads) to High(arrThreads) do
    begin
      CheckNot(arrThreads[i].IsError);
      arrThreads[i].Free;
    end;
    SetLength(arrThreads, 0);
    SetLength(arrHandles, 0);
  end;
end;

{ TMyHttpClient }

constructor TMyHttpClient.Create(const aServer,aPort: RawUTF8);
begin
  fModel:=TSQLModel.Create([TSQLRecordTest]);
  fCallback:=TCallback.Create;
  inherited Create(aServer, aPort, fModel);
end;

destructor TMyHttpClient.Destroy;
begin
  fCallback:=nil;
  fMyCommand:=nil;
  inherited;
  fModel.Free;
end;

function TMyHttpClient.SetUser(const aUserName, aPassword: RawUTF8; aHashedPassword: Boolean=false): boolean;
begin
  result := inherited SetUser(aUserName, aPassword, aHashedPassword);
  WebSocketsUpgrade(WEBSOCKET_KEY);
  if result then
  begin
    ServiceDefine([IMyCommand],sicClientDriven);
    Services.Resolve(IMyCommand, fMyCommand);
  end;
  fMyCommand.RegisterCallback(fCallback);
end;


{ TMyThread }

constructor TMyThread.Create(const aID, aRequestCount: integer);
begin
  inherited Create(true);
  fRequestCount:=aRequestCount;
  fId:=aId;
  fIsError:=false;
  fHttpClient := TMyHttpClient.Create('localhost', HTTP_PORT);
  fHttpClient.SetUser('Admin', 'synopse');
end;

destructor TMyThread.Destroy;
begin
  fHttpClient.Free;
  inherited;
end;

procedure TMyThread.Execute;
var
  i: integer;
  test: TTest;
  success: boolean;
begin
  test:=TTest.Create;
  try
    success:=true;
    for i:=0 to fRequestCount-1 do begin
      test.Description:=FormatUTF8('test-%-%',[fID, i]);
      success:=success and (fHttpClient.MyCommand.Add(test)=cqrsSuccess);
      if not success then
        break;
    end;
    if success then
      success:=fHttpClient.MyCommand.Commit=cqrsSuccess;
    if not success then
    begin
      fIsError:=true;
      raise Exception.Create('Something went wrong!');
    end;
  finally
    test.Free;
  end;
end;

{ TCallback }

procedure TCallback.DoCallback(const aDescription: RawUTF8);
begin
  //writeln('callback!');
end;

begin
  InitializeCriticalSection(gCriticalSection);
  with TMyTests.Create('mORMot DDD Test') do
  try
    Run;
  finally
    Free;
  end;
  WriteLn(#13#10'Done - Press ENTER to Exit');
  ReadLn;
  DeleteCriticalSection(gCriticalSection);
end.

program mORMotBug;

{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER

{$APPTYPE CONSOLE}

{$R *.res}

uses
  FastMM4,
  SysUtils,
  Classes,
  Windows,
  SynSqlite3Static,
  SynSqlite3,
  SynCommons,
  SynLog,
  SynTests,
  mORMot,
  mORMotHttpServer,
  mORMotHttpClient,
  mORMotSqlite3,
  mORMotDDD;

const
  HTTP_PORT = '80';

type
  // This is our simple Test data class. Will be mapped to TSQLRecordTest.
  TTest = class(TSynPersistent)
  private
    fDescription: RawUTF8;
  published
    property Description: RawUTF8 read fDescription write fDescription;
  end;
  TTestObjArray = array of TTest;

  // The corresponding TSQLRecord for TTest.
  TSQLRecordTest = class(TSQLRecord)
  private
    fDescription: RawUTF8;
  published
    property Description: RawUTF8 read fDescription write fDescription;
  end;

  // CQRS Query Interface fo TTest
  IMyQuery = interface(ICQRSService)
    ['{DD402806-39C2-4921-98AA-A575DD1117D6}']
    function SelectByDescription(const aDescription: RawUTF8): TCQRSResult;
    function SelectAll: TCQRSResult;
    function Get(out aAggregate: TTest): TCQRSResult;
    function GetAll(out aAggregates: TTestObjArray): TCQRSResult;
    function GetNext(out aAggregate: TTest): TCQRSResult;
    function GetCount: integer;
  end;

  // CQRS Command Interface for TTest
  IMyCommand = interface(IMyQuery)
    ['{F0E4C64C-B43A-491B-85E9-FD136843BFCB}']
    function Add(const aAggregate: TTest): TCQRSResult;
    function Update(const aUpdatedAggregate: TTest): TCQRSResult;
    function Delete: TCQRSResult;
    function DeleteAll: TCQRSResult;
    function Commit: TCQRSResult;
    function Rollback: TCQRSResult;
  end;

  // The infratructure REST class implementing the Query and Command Interfaces for TTest
  TTestRest = class(TDDDRepositoryRestCommand,IMyCommand,IMyQuery)
  public
    function SelectByDescription(const aDescription: RawUTF8): TCQRSResult;
    function SelectAll: TCQRSResult;
    function Get(out aAggregate: TTest): TCQRSResult;
    function GetAll(out aAggregates: TTestObjArray): TCQRSResult;
    function GetNext(out aAggregate: TTest): TCQRSResult;
    function Add(const aAggregate: TTest): TCQRSResult;
    function Update(const aUpdatedAggregate: TTest): TCQRSResult;
  end;

  // REST Factory for TTestRest instances
  TTestRestFactory = class(TDDDRepositoryRestFactory)
  public
    constructor Create(aRest: TSQLRest; aOwner: TDDDRepositoryRestManager=nil); reintroduce;
  end;

  // Test container
  TMyTests = class(TSynTestsLogged)
  published
    procedure MyTests;
  end;

  // Test case doing the actual work
  TMyTestCase = class(TSynTestCase)
  private
    // Rest server
    fRestServer: TSQLRestServerDB;
    // Http server
    fHttpServer: TSQLHttpServer;
    /// Will create as many Clients as specified by aClient.
    // - Each client will perform as many Requests as specified by aRequests.
    // - This function will wait for all Clients until finished.
    function ClientTest(const aClients, aRequests: integer):boolean;
  protected
    // Cleaning up the test
    procedure CleanUp; override;
  published
    // Delete any old Test database on start
    procedure DeleteOldDatabase;
    // Start the whole DDD Server (http and rest)
    procedure StartServer;
    // Test straight-forward access using 1 thread and 1 client
    procedure SingleClientTest;
    // Test concurrent access with multiple clients. This will crash!
    procedure MultiClientTest;
  end;

  // Custom TSQLHttpClient encapsulating the remote IMyCommand interface.
  TMyHttpClient=class(TSQLHttpClient)
  private
    // Internal Model
    fModel: TSQLModel;
    // IMyCommand interface. Will be assigned inside SetUser
    fMyCommand: IMyCommand;
  public
    constructor Create(const aServer,aPort: RawUTF8); //overload;
    destructor Destroy; override;
    function SetUser(const aUserName, aPassword: RawUTF8; aHashedPassword: Boolean=false): boolean; reintroduce;
    property MyCommand: IMyCommand read fMyCommand;
  end;

  // The thread used by TMyTestCase.ClientTest
  TMyThread = class(TThread)
  private
    fHttpClient: TMyHttpClient;
    fRequestCount: integer;
    fId: integer;
    fIsError: boolean;
  protected
    procedure Execute; override;
  public
    constructor Create(const aId, aRequestCount: integer);
    destructor Destroy; override;
    property IsError: boolean read fIsError;
  end;

{ TTestRest }

function TTestRest.SelectByDescription(
  const aDescription: RawUTF8): TCQRSResult;
begin
  result := ORMSelectOne('Description=?',[aDescription],(aDescription=''));
end;

function TTestRest.SelectAll: TCQRSResult;
begin
  result := ORMSelectAll('',[]);
end;

function TTestRest.Get(out aAggregate: TTest): TCQRSResult;
begin
  result := ORMGetAggregate(aAggregate);
end;

function TTestRest.GetAll(
  out aAggregates: TTestObjArray): TCQRSResult;
begin
  result := ORMGetAllAggregates(aAggregates);
end;

function TTestRest.GetNext(out aAggregate: TTest): TCQRSResult;
begin
  result := ORMGetNextAggregate(aAggregate);
end;

function TTestRest.Add(const aAggregate: TTest): TCQRSResult;
begin
  result := ORMAdd(aAggregate);
end;

function TTestRest.Update(
  const aUpdatedAggregate: TTest): TCQRSResult;
begin
  result := ORMUpdate(aUpdatedAggregate);
end;


{ TInfraRepoUserFactory }

constructor TTestRestFactory.Create(aRest: TSQLRest;
  aOwner: TDDDRepositoryRestManager);
begin
  inherited Create(IMyCommand,TTestRest,TTest,aRest,TSQLRecordTest,aOwner);
end;

{ TMyTests }

procedure TMyTests.MyTests;
begin
  AddCase([TMyTestCase]);
end;

{ TMyTestCase }

procedure TMyTestCase.CleanUp;
begin
  if Assigned(fHttpServer) then
    FreeAndNil(fHttpServer);
  if Assigned(fRestServer) then
    FreeAndNil(fRestServer);
end;

procedure TMyTestCase.DeleteOldDatabase;
begin
  if FileExists(ChangeFileExt(ParamStr(0), '.db3')) then
    SysUtils.DeleteFile(ChangeFileExt(ParamStr(0), '.db3'));
  CheckNot(FileExists(ChangeFileExt(ParamStr(0), '.db3')));
end;

procedure TMyTestCase.StartServer;
begin
  fRestServer:=TSQLRestServerDB.CreateWithOwnModel([TSQLRecordTest], ChangeFileExt(ParamStr(0), '.db3'), true);
  with fRestServer do begin
      DB.Synchronous := smNormal;
      DB.LockingMode := lmExclusive;
      CreateMissingTables();
      TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyQuery),TypeInfo(IMyCommand)]);
      ServiceContainer.InjectResolver([TTestRestFactory.Create(fRestServer)],true);
      ServiceDefine(TTestRest,[IMyCommand],sicClientDriven);
    end;
  fHttpServer:=TSQLHttpServer.Create(HTTP_PORT, fRestServer, '+', useHttpApiRegisteringURI);
end;

procedure TMyTestCase.MultiClientTest;
begin
  ClientTest(20,50);
end;

procedure TMyTestCase.SingleClientTest;
var
  HttpClient: TMyHttpClient;
  test: TTest;
  i: integer;
const
  MAX = 1000;
begin
  HttpClient:=TMyHttpClient.Create('localhost', HTTP_PORT);
  try
    Check(HttpClient.SetUser('Admin', 'synopse'));
    test:=TTest.Create;
    try
      for i:=0 to MAX-1 do begin
        test.Description:=FormatUTF8('test-%',[i]);
        Check(HttpClient.MyCommand.Add(test)=cqrsSuccess);
      end;
      Check(HttpClient.MyCommand.Commit=cqrsSuccess);
    finally
      test.Free;
    end;
  finally
    HttpClient.Free;
  end;
end;

function TMyTestCase.ClientTest(const aClients, aRequests: integer):boolean;
var
  i: integer;
  arrThreads: array of TMyThread;
  arrHandles: array of THandle;
  rWait: Cardinal;
begin
  result := false;
  SetLength(arrThreads, aClients);
  SetLength(arrHandles, aClients);
  for i:=Low(arrThreads) to High(arrThreads) do
  begin
    arrThreads[i]:=TMyThread.Create(i,aRequests);
    arrHandles[i]:=arrThreads[i].Handle;
    arrThreads[i].Resume;
  end;
  try
    repeat
      rWait:= WaitForMultipleObjects(aClients, @arrHandles[0], True, INFINITE);
    until rWait<>WAIT_TIMEOUT;
  finally
    for i:=Low(arrThreads) to High(arrThreads) do
    begin
      CheckNot(arrThreads[i].IsError);
      arrThreads[i].Free;
    end;
    SetLength(arrThreads, 0);
    SetLength(arrHandles, 0);
  end;
end;

{ TMyHttpClient }

constructor TMyHttpClient.Create(const aServer,aPort: RawUTF8);
begin
  fModel:=TSQLModel.Create([TSQLRecordTest]);
  inherited Create(aServer, aPort, fModel);
end;

destructor TMyHttpClient.Destroy;
begin
  fMyCommand:=nil;
  inherited;
  fModel.Free;
end;

function TMyHttpClient.SetUser(const aUserName, aPassword: RawUTF8; aHashedPassword: Boolean=false): boolean;
begin
  result := inherited SetUser(aUserName, aPassword, aHashedPassword);
  if result then
  begin
    ServiceDefine([IMyCommand],sicClientDriven);
    Services.Resolve(IMyCommand, fMyCommand);
  end;
end;


{ TMyThread }

constructor TMyThread.Create(const aID, aRequestCount: integer);
begin
  inherited Create(true);
  fRequestCount:=aRequestCount;
  fId:=aId;
  fIsError:=false;
  fHttpClient := TMyHttpClient.Create('localhost', HTTP_PORT);
  fHttpClient.SetUser('Admin', 'synopse');
end;

destructor TMyThread.Destroy;
begin
  fHttpClient.Free;
  inherited;
end;

procedure TMyThread.Execute;
var
  i: integer;
  test: TTest;
  success: boolean;
begin
  test:=TTest.Create;
  try
    success:=true;
    for i:=0 to fRequestCount-1 do begin
      test.Description:=FormatUTF8('test-%-%',[fID, i]);
      success:=success and (fHttpClient.MyCommand.Add(test)=cqrsSuccess);
      if not success then
        break;
    end;
    if success then
      success:=fHttpClient.MyCommand.Commit=cqrsSuccess;
    if not success then
    begin
      fIsError:=true;
      raise Exception.Create('Something went wrong!');
    end;
  finally
    test.Free;
  end;
end;

begin
//  TSynLogTestLog := TSQLLog; // share the same log file with whole mORMot
  TSQLLog.Family.Level := LOG_STACKTRACE; // log errors by default
  TSQLLog.Family.Level := []; // NO log by default (ignore expected ERROR 400)
  with TMyTests.Create('mORMot DDD Test') do
  try
    Run;
  finally
    Free;
  end;
  WriteLn(#13#10'Done - Press ENTER to Exit');
  ReadLn;
end.