mORMot Open Source

oz

Member

Registered: 2015-09-02

Posts: 98

Possibly a Serious bug in mORMot's DDD functionality!

Hi Arnaud,
I'm currently working on a mORMot based server using it's DDD (doman driven design) functionality.
While creating a TestCase for concurrent client access to the server, i've faced a serious problem.
I created a Test project for reproducing the bug by extracting all the relevant parts of my sources. The Test is attached as a single, compileable .DPR file.
Delphi 7 is used for compiling.

The problem is in TMyTestCase.MultiClientTest.
When using a single client instance, everything works just fine. But as soon as there are at least 2 client instances, things start getting wrong. At some point a "ESQLite3Exception ("Error SQLITE_ERROR (1) using 3.8.8.1 - 'cannot rollback - no transaction is active' extended_errcode=1")" is raised when calling TTestRest.Commit.

Just run the attached program and see what is happing.

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.

Now, the question is: is there something wrong with my test source, or is this a problem in mORMot's DDD functionality?

I'm looking forward to hearing from you!

ab

Administrator

From: France

Registered: 2010-06-21

Posts: 14,660

Website

Re: Possibly a Serious bug in mORMot's DDD functionality!

First, ensure you got the latest version of SQLite3.
Your *.obj seems deprecated (3.8.8.1).

See also http://synopse.info/forum/viewtopic.php?id=2298

I will check your source.

oz

Member

Registered: 2015-09-02

Posts: 98

Re: Possibly a Serious bug in mORMot's DDD functionality!

Hi Arnaud,
thanks for your quick reply. I've just downloaded and installed the latest sqlite3.obj and sqlite3fts.obj files, but it didn't help. The problem still exists. I'll check your link in a minute...

oz

Member

Registered: 2015-09-02

Posts: 98

Re: Possibly a Serious bug in mORMot's DDD functionality!

It's me again
I've just read the link you provided. I think I get the point, but i don't see any connection between this problem and the one from the other thread. There is no "playing around" with transactions in the test project. It is based on mORMot's standard DDD implementation, no custom transaction or batch processing is done here.

danielkuettner

Member

From: Germany

Registered: 2014-08-06

Posts: 357

Re: Possibly a Serious bug in mORMot's DDD functionality!

I would first split server and client project and then test again.

oz

Member

Registered: 2015-09-02

Posts: 98

Re: Possibly a Serious bug in mORMot's DDD functionality!

I would first split server and client project and then test again.

I've already thought about that, but:
-It would make the automated test suite much more complicated. A seperate server process has to be compiled, started, managed and stopped by the test. Server exceptions will happen in another process, ...
-The mORMot framework should be able to pass such tests. I don't see any reasons why this shouldn't work inside a single process. There already are other tests dealing with concurrent access to the server in the test suite. These test do pass, so should this one. mORMot DDD Layer doesn't introduce any kind of magic.. it's based on well known mORMot bricks, the composition of those bricks simply should work.

I think you made this proposal because hosting multiple clients instances inside server process could/will slow down response times. But the same thing -slow down because of heavy load- could happen in production use too. mORMot is a fantastic framework with great performance and should be able to handle such usage without any problem.

Last edited by oz (2015-09-08 10:24:49)

oz

Member

Registered: 2015-09-02

Posts: 98

Re: Possibly a Serious bug in mORMot's DDD functionality!

I would first split server and client project and then test again.

I've done the split for debugging purpoises, but the problem remains.
Server source:

program mORMotBugServer;

{$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;

{ 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;


var
  fRestServer: TSQLRestServerDB;
  fHttpServer: TSQLHttpServer;
begin
  if FileExists(ChangeFileExt(ParamStr(0), '.db3')) then
    SysUtils.DeleteFile(ChangeFileExt(ParamStr(0), '.db3'));
  fRestServer:=TSQLRestServerDB.CreateWithOwnModel([TSQLRecordTest], ChangeFileExt(ParamStr(0), '.db3'), true);
  try
    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);
    try
      WriteLn(#13#10'Server running - Press ENTER to Exit');
      ReadLn;
    finally
      fHttpServer.Free;
    end;
  finally
    fRestServer.Free;
  end;
end.

Clients source:

program mORMotBugClients;

{$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;

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

  // Test case doing the actual work
  TMyTestCase = class(TSynTestCase)
  private
    /// 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;
  published
    // 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;


{ TMyTests }

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

{ TMyTestCase }

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
    TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyQuery),TypeInfo(IMyCommand)]);
    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
  with TMyTests.Create('mORMot DDD Test') do
  try
    Run;
  finally
    Free;
  end;
  WriteLn(#13#10'Done - Press ENTER to Exit');
  ReadLn;
end.

oz

Member

Registered: 2015-09-02

Posts: 98

Re: Possibly a Serious bug in mORMot's DDD functionality!

After further investigation:
It looks like if this is a client side problem. When using only one TSQLHttpClient instance per client exe-process it seems to work just fine. I've made a Test running the standalone server and 10 client.exe processes. Each client instance using only 1 TSQLHttpClient. Each of the 10 clients did insert 50000 records without any problem.

ab

Administrator

From: France

Registered: 2010-06-21

Posts: 14,660

Website

Re: Possibly a Serious bug in mORMot's DDD functionality!

There was indeed a problem.
On the server side.

Should be fixed by http://synopse.info/fossil/info/80934ad438

I've also added the corresponding regression tests to the official test suite.
See http://synopse.info/fossil/info/9c1e76510b

Thanks a lot for providing the tests cases to reproduce the issue.
It was very easy to fix, once identified.

oz

Member

Registered: 2015-09-02

Posts: 98

Re: Possibly a Serious bug in mORMot's DDD functionality!

Great! Thanks a lot for your support and this fantastic framework in general!

ab

Administrator

From: France

Registered: 2010-06-21

Posts: 14,660

Website

Re: Possibly a Serious bug in mORMot's DDD functionality!

You are welcome.

This is weird that we did not observe this issue on production yet.

Thanks to the regression tests, we could now prevent any similar problem on this matter.
Multi-threading is hard!

oz

Member

Registered: 2015-09-02

Posts: 98

Re: Possibly a Serious bug in mORMot's DDD functionality!

Thank you for integrating my tests into the framework!

Yeah, Multi-thread could be hard, but mastered at the end

Well, when talking about multi threading...

In my current project, there will be soon the need to run defined jobs at planned times (TDateTime) inside the server process.
Those jobs are well defined happenings in my domain, but leaving the domain language and going technically:
At the end, a "job" will be a function called by a thread and do something like:

procedure ThisJobWillBeRunByAThreadpoolThreadAtDateTime;
var
  cmdA: IMyCommandA;  // a DDD CQRS interface
  cmdB: IMyCommandB; // another DDD CQRS interface
  fAuthUserCmd: IDomUkiAuthUserCommand;
begin
  Factory.Rest.Services.Resolve(IMyCommandA, cmdA);
  Factory.Rest.Services.Resolve(IMyCommandB, cmdB);
  if cmdA.Foo then
    if cmdB.Bar;
end;

Is there some kind of abstract Threadpool included in the framework which i could use for creating such a feature?

Last edited by oz (2015-09-08 19:26:59)