mORMot Open Source

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 305
  ClientWidth = 393
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object bServer: TSpeedButton
    Left = 7
    Top = 8
    Width = 60
    Height = 26
    AllowAllUp = True
    GroupIndex = 1
    Caption = 'Server'
    OnClick = Button1Click
  end
  object bClient: TSpeedButton
    Left = 73
    Top = 8
    Width = 60
    Height = 26
    AllowAllUp = True
    GroupIndex = 2
    Caption = 'Client'
    OnClick = Button2Click
  end
  object Memo1: TMemo
    Left = 8
    Top = 74
    Width = 185
    Height = 215
    ReadOnly = True
    TabOrder = 0
  end
  object eHost: TEdit
    Left = 8
    Top = 47
    Width = 130
    Height = 21
    TabOrder = 1
    Text = 'localhost'
  end
  object Memo2: TMemo
    Left = 199
    Top = 74
    Width = 185
    Height = 215
    ReadOnly = True
    TabOrder = 2
  end
  object ePort: TEdit
    Left = 144
    Top = 47
    Width = 38
    Height = 21
    TabOrder = 3
    Text = '9000'
  end
  object eInterval: TLabeledEdit
    Left = 327
    Top = 47
    Width = 57
    Height = 21
    EditLabel.Width = 38
    EditLabel.Height = 13
    EditLabel.Caption = 'Interval'
    TabOrder = 4
    Text = '100'
  end
  object Timer1: TTimer
    Enabled = False
    Interval = 100
    OnTimer = Timer1Timer
    Left = 264
    Top = 40
  end
end

unit frmMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.Buttons,

  SynCommons,
  mORMot,
  mORMotHttpClient,
  mORMotHttpServer,
  SynBidirSock;

type
  TOSSServer = class;
  TOSSMessage = class;
  TOssCallback = class;

  IOSSMessage = interface(IInvokable)
  ['{4F30D230-AA46-4013-A900-33A7B79DD175}']
    function GetTimeStamp: TDateTimeMS;
    procedure SetTimeStamp(const Value: TDateTimeMS);
    property TimeStamp: TDateTimeMS read GetTimeStamp write SetTimeStamp;
  end;

  TOSSMessage = class(TPersistent)
  private
    fTimeStamp: TDateTimeMS;
    function GetTimeStamp: TDateTimeMS;
    procedure SetTimeStamp(const Value: TDateTimeMS);
  published
    property TimeStamp: TDateTimeMS read GetTimeStamp write SetTimeStamp;
  end;

  IOSSCallback = interface(IInvokable)
    ['{C561AB6F-61E0-4009-A1A0-26630A6A6D1F}']
    procedure ReceiveOssMessage(const AOSSMessage: TOSSMessage);
  end;

  IOSSService = interface(IInvokable)
    ['{DDB2805E-3521-4784-928B-95CE0B9FB4DD}']
    procedure SendOssMessage(const AOSSMessage: TOSSMessage);
    procedure SubscribeToOss(const ACallback: IOSSCallback);
  end;

  TForm1 = class(TForm)
    Memo1: TMemo;
    eHost: TEdit;
    Memo2: TMemo;
    bServer: TSpeedButton;
    bClient: TSpeedButton;
    ePort: TEdit;
    eInterval: TLabeledEdit;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    fHttpServer: TSQLHttpServer;
    fWebSocketServerRest: TWebSocketServerRest;
    fServer: TSQLRestServerFullMemory;
    fClient: TSQLHttpClientWebsockets;
    fService: IOSSService;
    fCallback: IOSSCallback;
  public
    procedure BeforeDestruction; override;
    property HttpServer: TSQLHttpServer read fHttpServer;
    property WebSocketServerRest: TWebSocketServerRest read fWebSocketServerRest;
    property Server: TSQLRestServerFullMemory read fServer;
  end;

  TOSSServer = class(TInterfacedObject, IOSSService)
  private
    fClients: TInterfaceList;
  protected
    procedure SendOssMessage(const AOSSMessage: TOSSMessage);
    procedure SubscribeToOss(const ACallback: IOSSCallback);
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    procedure ServiceStart();
  published
  end;

  TOssCallback = class(TInterfacedCallback,IOSSCallback)
  private
  protected
    procedure ReceiveOssMessage(const AOSSMessage: TOSSMessage);
  end;

var
  Form1: TForm1;
  Lock: TRTLCriticalSection;

implementation

{$R *.dfm}

uses
  System.DateUtils;

const
  TRANSMISSION_KEY = 'OSS_WebSockets';

procedure TForm1.BeforeDestruction;
begin
  inherited;
  fService := nil;
  fCallback := nil;
  FreeAndNil(fHttpServer);
  FreeAndNil(fServer);
  FreeAndNil(fClient);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Port: string;
begin
  if not bServer.Down then
  begin
    FreeAndNil(fHttpServer);
    FreeAndNil(fServer);
    exit;
  end;
  fServer := TSQLRestServerFullMemory.CreateWithOwnModel([]);
  Server.ServiceDefine(TOSSServer,[IOSSService],sicShared).ByPassAuthentication := true;
  Server.CreateMissingTables;
  fHttpServer := TSQLHttpServer.Create(ePort.text, [Server], '+', useBidirSocket, 32, secSynShaAes, 'OSS');
  fWebSocketServerRest := HttpServer.WebSocketsEnable(Server, TRANSMISSION_KEY, True);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  s: string;
begin
  if not bClient.Down then
  begin
    Timer1.Enabled := false;
    fService := nil;
    fCallback := nil;
    FreeAndNil(fClient);
    exit;
  end;
  fClient := TSQLHttpClientWebsockets.Create(eHost.Text, ePort.Text, TSQLModel.Create([]));
  fClient.Model.Owner := fClient;
  s := fClient.WebSocketsUpgrade(TRANSMISSION_KEY);
  if s <> '' then
    raise Exception.Create(s);
  if not fClient.ServerTimeStampSynchronize then
    raise Exception.CreateFmt(fClient.LastErrorMessage+
      '. Error connecting to OSS server at %s:%d', [fClient.HostName, fClient.Port]);
  fClient.ServiceDefine([IOSSService],sicShared);
  if not fClient.Services.Resolve(IOSSService, fService) then
    raise Exception.Create('Service IOSSService unavailable');
  fCallback := TOssCallback.Create(fClient, IOssCallback);
  fService.SubscribeToOss(fCallback);
  Timer1.Enabled := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  vMessage: TOSSMessage;
begin
  vMessage := TOSSMessage.Create;
  try
    vMessage.TimeStamp := now;
    Timer1.Interval := StrToIntDef(eInterval.Text, Timer1.Interval);
    try
      fService.SendOssMessage(vMessage);
    except
      on e: exception do
      begin
        Timer1.Enabled := false;
        Form1.Memo2.Lines.Add(e.Message);
        raise;
      end;
    end;
  finally
    vMessage.Free;
  end;
end;

{ TOSSServer }

procedure TOSSServer.AfterConstruction;
begin
  inherited;
  ServiceStart;
end;

procedure TOSSServer.BeforeDestruction;
begin
  inherited;
  fClients.Free;
end;

procedure TOSSServer.SendOssMessage(const AOSSMessage: TOSSMessage);
var
  i: integer;
begin
  for I := 0 to fClients.Count - 1 do
  try
    (fClients[i] as IOSSCallback).ReceiveOssMessage(AOSSMessage);
  except

  end;
end;

procedure TOSSServer.ServiceStart;
begin
  fClients := TInterfaceList.Create;
end;

procedure TOSSServer.SubscribeToOss(const ACallback: IOSSCallback);
begin
  fClients.Add(ACallBack);
end;

{ TOssCallback }

procedure TOssCallback.ReceiveOssMessage(const AOSSMessage: TOSSMessage);
var
  LatencyMS: integer;
begin
  EnterCriticalSection(Lock);
  try
    LatencyMS := MilliSecondsBetween(now, AOSSMessage.TimeStamp);
    Form1.Memo2.Lines.Add(IntToStr(LatencyMS));
  finally
    LeaveCriticalSection(Lock);
  end;
end;

{ TOSSMessage }

function TOSSMessage.GetTimeStamp: TDateTimeMS;
begin
  result := fTimeStamp;
end;

procedure TOSSMessage.SetTimeStamp(const Value: TDateTimeMS);
begin
  fTimeStamp := Value;
end;

initialization
  TInterfaceFactory.RegisterInterfaces([
    TypeInfo(IOSSMessage),
    TypeInfo(IOSSService),
    TypeInfo(IOSSCallback)]);
  InitializeCriticalSection(Lock);

finalization
  DeleteCriticalSection(Lock);
end.