mORMot Open Source

begin
  result := false;
  OnlyTestForNull := (Buffer=nil);
  RowIndex := PRecInfo(ActiveBuffer).RowIndentifier;
  Data := GetRowFieldData(Field,RowIndex,DataLen,OnlyTestForNull);
  if Data=nil then // on success, points to Int64,Double,Blob,UTF8
    exit;
  result := true;
  if OnlyTestForNull then
    exit;
  Dest := pointer(Buffer); // works also if Buffer is [var] TValueBuffer
  case Field.DataType of
  ftBoolean:
    PWORDBOOL(Dest)^ := PBoolean(Data)^;
  ftInteger:
    PInteger(Dest)^ := PInteger(Data)^;
  ftLargeint, ftFloat, ftCurrency:
    PInt64(Dest)^ := PInt64(Data)^;
  ftDate,ftTime,ftDateTime: begin
    if PDateTime(Data)^ = 0 then begin
      result := false;
      exit;
    end;
    DataConvert(Field,Data,Dest,true);
  end;
  ftString: begin
    if DataLen<>0 then begin
      CurrentAnsiConvert.UTF8BufferToAnsi(Data,DataLen,Temp);
      DataLen := length(Temp);
      MaxLen := Field.DataSize-1; // without trailing #0
      if DataLen>MaxLen then
        DataLen := MaxLen;
      move(pointer(Temp)^,Dest^,DataLen);
    end;
    PAnsiChar(Dest)[DataLen] := #0;
  end;
  ftWideString: begin
    {$ifdef ISDELPHI2007ANDUP} // here Dest = PWideChar[] of DataSize bytes
    if DataLen=0 then
      PWideChar(Dest)^ := #0 else
      UTF8ToWideChar(Dest,Data,(Field.DataSize-2)shr 1,DataLen);
    {$else}          // here Dest is PWideString
    UTF8ToWideString(Data,DataLen,WideString(Dest^));
    {$endif}
  end;
  // ftBlob,ftMemo,ftWideMemo should be retrieved by CreateBlobStream()
  else raise EDatabaseError.CreateFmt('%s.GetFieldData DataType=%d',
         [ClassName,ord(Field.DataType)]);
  end;
end;

  TSQLTESTRestServerDB = class(TSQLRestServerDB)
    public
      onMount: TSQLRestServerCallBack;
      onUnmount: TSQLRestServerCallBack;
    published
      procedure Mount(Ctxt: TSQLRestServerURIContext);
      procedure Unmount(Ctxt: TSQLRestServerURIContext);
  end;

  TMainServer = class(TObject)
  protected
    procedure SetLog;
    procedure Connect;
    function OnConnect(Sender: TSQLRestServer; Session: TAuthSession; Ctxt: TSQLRestServerURIContext): boolean;
    function OnDisconnect(Sender: TSQLRestServer; Session: TAuthSession; Ctxt: TSQLRestServerURIContext): boolean;
    function OnUpdate(Sender: TSQLRestServer; Event: TSQLEvent; aTable: TSQLRecordClass; const aID: TID; const aSentData: RawUTF8): boolean;
  public
    fLog: TSynLog;
    fMODELBDD: TSQLModel;
    fBDD: TSQLDataBase;
    fREST: TSQLTESTRestServerDB;
    fRestTab: TObjectDictionary<RawUTF8, TSQLRestServerDB>;
    fHTTPServer: TSQLHttpServer;

    constructor Create;
    destructor Destroy; override;
    procedure MountREST(Ctxt: TSQLRestServerURIContext);
    procedure UnmountREST(Ctxt: TSQLRestServerURIContext);
  end;

  fMODELBDD := TSQLModel.Create([]);
  try
    fBDD := TSQLDataBase.Create(ExeVersion.ProgramFilePath+'MainTest.s3db', '', SQLITE_OPEN_CREATE or SQLITE_OPEN_READWRITE);
    try
      fREST := TSQLTESTRestServerDB.Create(fMODELBDD, fBDD, True);
      try
        fREST.CreateMissingTables();

        fREST.OnSessionCreate := OnConnect;
        fREST.OnSessionClosed := OnDisconnect;
        fREST.OnUpdateEvent := OnUpdate;

        //My events
        fREST.onMount := MountREST;
        fREST.onUnmount := UnmountREST;
        // /

          fHTTPServer := TSQLHttpServer.Create(AnsiString('8080'), [fREST], '+', useHttpApiRegisteringURI);
          try
            fRestTab := TObjectDictionary<RawUTF8, TSQLRestServerDB>.Create([doOwnsValues]);

            fLog.Add.Log(sllInfo, ' - Init ok');
            fLog.Add.Log(sllInfo, ' - Server set on port ::8080::');
          except
            FreeAndNil(fHTTPServer);
          end;
      except
        FreeAndNil(fREST);
      end;
    except
      FreeAndNil(fBDD);
    end;
  except
    FreeAndNil(fMODELBDD);
  end;

procedure TMainServer.MountREST(Ctxt: TSQLRestServerURIContext);
var ref: RawUTF8;
begin
  if UrlDecodeNeedParameters(Ctxt.Parameters, 'ref') then begin
    ref := Ctxt['ref'];
    fLog.Enter();
    fLog.Add.Log(sllInfo, 'Ref: '+ref);

    if fRestTab.ContainsKey(ref) then begin
      //If already mounted
      Ctxt.Results([ref]);
    end else begin
      //if not
      fRestTab.Add(ref,
        TSQLRestServerDB.Create(
          TSQLModel.Create([], ref),
          TSQLDataBase.Create(ExeVersion.ProgramFilePath+ref+'.s3db', '', SQLITE_OPEN_CREATE or SQLITE_OPEN_READWRITE), True)
        );
      try
        //fRestTab.Items[refUniqueServeur].Model.Owner := fRestTab.Items[refUniqueServeur];    //Is this usefull?
        fRestTab.Items[ref].CreateMissingTables;

        if fHTTPServer.AddServer(fRestTab.Items[ref]) then begin
          Ctxt.Results([ref]);
          fLog.Add.Log(sllInfo, ' ++ '''+ref+''' mounted');
        end else begin
          fLog.Add.Log(sllError, ' xx '''+ref+''' couldn''t be mounted');
        end;
      except
        fRestTab.Items[ref].DB.DBClose;
        fRestTab.Items[ref].DB.Free;
        fRestTab.Items[ref].Model.Free;
        fRestTab.Remove(ref);
        fLog.Add.Log(sllError, 'failure while mounting: '+ref);
      end;
    end;

  end else begin
    fLog.Add.Log(sllError, 'Mount called without parameter');
    Ctxt.Results(['ERREUR: ref missing']);
  end;
end;

    if fHTTPServer.RemoveServer(fRestTab.Items[ref]) then begin
      fRestTab.Items[ref].DB.DBClose;
      fRestTab.Items[ref].DB.Free;
      fRestTab.Items[ref].Model.Free;
      fRestTab.Remove(ref);  //autoFree because of [doOwnsValues]
      fLog.Add.Log(sllInfo, ' -- '''+ref+''' unmounted');
    end else begin
      fLog.Add.Log(sllError, ' xx '''+ref+''' couldn''t be unmounted');
    end;

//Connection to the first REST
  fClient1 := TSQLHttpClient.Create('localhost', '8080', TSQLModel.Create([]), false);
  if not fClient1.ServerTimeStampSynchronize then
    raise Exception.Create('Fail while timestamp synchro');
  if not fClient1.SetUser('Admin', 'synopse') then
    raise Exception.Create('Fail while SetUser');
//Call MountREST without connecting to it
  fClient1.CallBackGetResult('Mount', ['ref', 'TEST002']);
//Then unmount and disconnect
  fClient1.CallBackGetResult('Unmount', ['ref', 'TEST002']);
  FreeAndNil(fClient1);

//Connection to the first REST
  fClient1 := TSQLHttpClient.Create('localhost', '8080', TSQLModel.Create([]), false);
  if not fClient1.ServerTimeStampSynchronize then
    raise Exception.Create('Fail while timestamp synchro');
  if not fClient1.SetUser('Admin', 'synopse') then
    raise Exception.Create('Fail while SetUser');
//Call MountREST and connect to it
  fClient1.CallBackGetResult('Mount', ['ref', 'TEST002']);
  fClient2 := TSQLHttpClient.Create('localhost', '8080', TSQLModel.Create([], 'TEST002'), false);
  if not fClient2.ServerTimeStampSynchronize then
    raise Exception.Create('CLIENT2: Fail while timestamp synchro');
  if not fClient2.SetUser('Admin', 'synopse') then
    raise Exception.Create('CLIENT2: Fail while SetUser');
//Then disconnect, unmount and disconnect again
  FreeAndNil(fClient2);
  fClient1.CallBackGetResult('Unmount', ['ref', 'TEST002']);
  FreeAndNil(fClient1);

unit IMainServerCS;
interface
uses
  SysUtils, SynCommons, mORMot;

type
  IMainServCallback = interface(IInvokable)
    ['{7E7CA6D9-DA5A-4524-8257-41B14F2DBE8A}']
    procedure sendMsg(const ID: integer; const msg: string);
  end;

  IMainServService = interface(IServiceWithCallbackReleased)
    ['{397EBE90-AAA0-4ED2-BDEA-ED566585565A}']
    procedure Connect(const callback: IMainServCallback);
    function TotalConnected: Integer;
  end;

const
  TRANSMISSION_KEY = 'SECRET';

implementation

initialization
  TInterfaceFactory.RegisterInterfaces(
    [TypeInfo(IMainServService), TypeInfo(IMainServCallback)]);
end.

type
  TMainServer = class(TInterfacedObject, IMainServService)
  protected
    fConnected: array of IMainServCallback;

    procedure SetLog;
    procedure SetConnection;
    procedure FreeAll;
  public
    fLog: TSynLog;
    fMODELBDD: TSQLModel;
    fBDD: TSQLDataBase;
    fRestServer: TSQLRestServerDB;
    fHTTPServer: TSQLHttpServer;
    fWebApp: TOtherWebApp;

    constructor Create;
    destructor Destroy; override;

    // INTERFACE SERVICE
    procedure Connect(const callback: IMainServCallback);
    procedure CallbackReleased(const callback: IInvokable; const interfaceName: RawUTF8);
    function TotalConnected: Integer;
  end;

implementation

{ TMainServeur }
constructor TMainServer.Create;
begin
  inherited;
  Self.SetLog;            //Init logs
  Self.SetConnection;   //Init connection
end;

destructor TMainServer.Destroy;
begin
  fLog.Enter(self, '::Destroy::');
  Self.FreeAll;
  inherited;
end;

procedure TMainServer.SetLog;
begin
  fLog := TSynLog.Add;
  with fLog.Family do begin
    {$IFDEF CONSOLE}
      EchoToConsole := LOG_VERBOSE;
    {$ENDIF}
    Level := LOG_VERBOSE;
    TSynLogTestLog := TSQLLog;
    RotateFileCount := 5;
    OnArchive := EventArchiveSynLZ;
    ArchiveAfterDays := 1;
    ArchivePath := ExeVersion.ProgramFilePath+'log\archive';
    PerThreadLog := ptIdentifiedInOnFile;
    DestinationPath := ExeVersion.ProgramFilePath+'log\';
    EndOfLineCRLF := true;
    AutoFlushTimeOut := 6;
  end;
  WebSocketLog := TSQLLog;
end;

procedure TMainServer.FreeAll;
begin
  fHTTPServer.Shutdown;
  if Assigned(fHTTPServer) then
    FreeAndNil(fHTTPServer);
  if Assigned(fWebApp) then
    FreeAndNil(fWebApp);
  if fRestServer <> nil then
    fRestServer := nil;
  if Assigned(fBDD) then
    FreeAndNil(fBDD);
  if Assigned(fMODELBDD) then
    FreeAndNil(fMODELBDD);
end;


procedure TMainServer.SetConnection;
begin
  fLog.Enter(self, ' - Init server...');

  fMODELBDD := TSQLModel.Create([TSQLUser, TSQLOther]);
  try
    fBDD := TSQLDataBase.Create(ExeVersion.ProgramFilePath+DB, '', SQLITE_OPEN_CREATE or SQLITE_OPEN_READWRITE);
    try
      fRestServer := TSQLRestServerDB.Create(fMODELBDD, fBDD, True);
      try
        fRestServer.AuthenticationUnregister(TSQLRestServerAuthenticationSSPI);
        fRestServer.CreateMissingTables(); 
        fRestServer.DB.LockingMode := lmExclusive;
        fRestServer.ServiceDefine(TMainServeur, [IMainServService], sicShared).
            SetOptions([],[optExecLockedPerInterface]);

        fWebApp := TOtherWebApp.Create;
        try
          fWebApp.parent := nil;
          fWebApp.Start(fRestServer);

          fHTTPServer := TSQLHttpServer.Create(AnsiString(PORT_CONNECT), [fRestServer], '+', useBidirSocket);
          try
            fHTTPServer.WebSocketsEnable(fRestServer, TRANSMISSION_KEY).
                Settings.SetFullLog;
            fHTTPServer.RootRedirectToURI('root/Default');
            fHTTPServer.AccessControlAllowOrigin := '*';
          except
            FreeAndNil(fHTTPServer);
          end;
        except
          FreeAndNil(fWebApp);
        end;
      except
        fRestServer := nil;
      end;
    except
      FreeAndNil(fBDD);
    end;
  except
    FreeAndNil(fMODELBDD);
  end;
end;



procedure TMainServer.Connect(const callback: IMainServCallback);
begin
  InterfaceArrayAdd(fConnected, callback);

  TSynLog.Add.Log(sllInfo, ' ++ Connect. '+IntToStr(self.TotalConnected+1)+' user(s).');
end;

procedure TMainServer.CallbackReleased(const callback: IInvokable; const interfaceName: RawUTF8);
begin
  if interfaceName='IMainServCallback' then begin
    InterfaceArrayDelete(fConnected, callback);
    TSynLog.Add.Log(sllInfo, ' -- Disconnect. Still '+IntToStr(self.TotalConnected+1)+' user(s).');
  end;
end;

function TMainServer.TotalConnected: Integer;
begin
  result := high(fConnected);
end;

end.

type
  TMainServCallback = class(TInterfacedCallback, IMainServCallback)
    protected
      procedure sendMsg(const ID: integer; const msg: string);
  end;

[...]

procedure TMainServCallback.sendMsg(const ID: integer; const msg: string);
begin
  //do something
end;
end.

procedure TTestCaseConnection.TestConnection;
var
  FClient: TSQLHttpClientWebsockets;
  FService: IMainServService;
  FCallback: IMainServCallback;
begin
  FClient := TSQLHttpClientWebsockets.Create(AnsiString(SYN_ADRESSE), AnsiString(SYN_PORT), TSQLModel.Create([TSQLUser, TSQLOther]));
  try
    FClient.Model.Owner := FClient;
    FClient.WebSocketsUpgrade(TRANSMISSION_KEY);

    FClient.ServerTimeStampSynchronize;

    FClient.SetUser(SYN_USER_NAME, TSQLUser.ComputeHashedPassword(SYN_USER_PASS), true);

    //callback/service
    FClient.ServiceDefine([IMainServService], sicShared);
    FClient.Services.Resolve(IMainServService, FService);

    FCallback := TMainServCallback.Create(FClient, IMainServCallback);
    try
      FService.Connect(FCallback, 'XX');

      [.. do something .. ]

    finally
      FCallback := nil;
      FService := nil;
    end;
  finally
    FClient.SessionClose;
    FreeAndNil(FClient);
  end;
end;