source upload

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31ChatCallbackInterface.pas

@@ -0,0 +1,31 @@
+unit Project31ChatCallbackInterface;
+
+interface
+
+uses
+  SysUtils,
+  SynCommons,
+  mORMot;
+
+type
+  IChatCallback = interface(IInvokable)
+    ['{EA7EFE51-3EBA-4047-A356-253374518D1D}']
+    procedure NotifyBlaBla(const pseudo, msg: string);
+  end;
+
+  IChatService = interface(IServiceWithCallbackReleased)
+    ['{C92DCBEA-C680-40BD-8D9C-3E6F2ED9C9CF}']
+    procedure Join(const pseudo: string; const callback: IChatCallback);
+    procedure BlaBla(const pseudo, msg: string);
+  end;
+
+const
+  PROJECT31_TRANSMISSION_KEY = 'meow_privatekey';
+
+  
+implementation
+
+initialization
+  TInterfaceFactory.RegisterInterfaces([
+    TypeInfo(IChatService),TypeInfo(IChatCallback)]);
+end.

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31ChatClient.dpr

@@ -0,0 +1,85 @@
+/// simple SOA client using callbacks for a chat room
+program Project31ChatClient;
+
+{$APPTYPE CONSOLE}
+
+uses
+  {$I SynDprUses.inc} // use FastMM4 on older versions of Delphi
+  SysUtils,
+  Classes,
+  SynCommons,
+  mORMot,
+  mORMotHttpClient,
+  Project31ChatCallbackInterface in 'Project31ChatCallbackInterface.pas';
+
+type
+  TChatCallback = class(TInterfacedCallback,IChatCallback)
+  protected
+    procedure NotifyBlaBla(const pseudo, msg: string);
+  end;
+
+procedure TChatCallback.NotifyBlaBla(const pseudo, msg: string);
+begin
+  TextColor(ccLightBlue);
+  writeln(#13'@',pseudo,' ',msg);
+  TextColor(ccLightGray);
+  write('>');
+end;
+
+procedure Run;
+var Client: TSQLHttpClientWebsockets;
+    pseudo,msg: string;
+    Service: IChatService;
+    callback: IChatCallback;
+begin
+  writeln('Connecting to the local Websockets server...');
+  Client := TSQLHttpClientWebsockets.Create('127.0.0.1','8888',TSQLModel.Create([]));
+  try
+    Client.Model.Owner := Client;
+    Client.WebSocketsUpgrade(PROJECT31_TRANSMISSION_KEY);
+    if not Client.ServerTimeStampSynchronize then
+      raise EServiceException.Create(
+        'Error connecting to the server: please run Project31ChatServer.exe');
+    Client.ServiceDefine([IChatService],sicShared);
+    if not Client.Services.Resolve(IChatService,Service) then
+      raise EServiceException.Create('Service IChatService unavailable');
+    try
+      TextColor(ccWhite);
+      writeln('Please enter you name, then press [Enter] to join the chat');
+      writeln('Enter a void line to quit');
+      write('@');
+      TextColor(ccLightGray);
+      readln(pseudo);
+      if pseudo='' then
+        exit;
+      callback := TChatCallback.Create(Client,IChatCallback);
+      Service.Join(pseudo,callback);
+      TextColor(ccWhite);
+      writeln('Please type a message, then press [Enter]');
+      writeln('Enter a void line to quit');
+      repeat
+        TextColor(ccLightGray);
+        write('>');
+        readln(msg);
+        if msg='' then
+          break;
+        Service.BlaBla(pseudo,msg);
+      until false;
+    finally
+      callback := nil; // will unsubscribe from the remote publisher
+      Service := nil;  // release the service local instance BEFORE Client.Free
+    end;
+  finally
+    Client.Free;
+  end;
+end;
+
+
+begin
+  try
+    Run;
+  except
+    on E: Exception do
+      ConsoleShowFatalException(E);
+  end;
+end.

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31ChatServer.dpr

@@ -0,0 +1,96 @@
+/// simple SOA server using callbacks for a chat room
+program Project31ChatServer;
+
+{$APPTYPE CONSOLE}
+
+uses
+  {$I SynDprUses.inc} // use FastMM4 on older versions of Delphi
+  SysUtils,
+  Classes,
+  SynCommons,
+  SynTable,
+  SynLog,
+  mORMot,
+  SynBidirSock,
+  mORMotHttpServer,
+  Project31ChatCallbackInterface in 'Project31ChatCallbackInterface.pas';
+
+type
+  TChatService = class(TInterfacedObject,IChatService)
+  protected
+    fConnected: array of IChatCallback;
+  public
+    procedure Join(const pseudo: string; const callback: IChatCallback);
+    procedure BlaBla(const pseudo,msg: string);
+    procedure CallbackReleased(const callback: IInvokable; const interfaceName: RawUTF8);
+  end;
+
+procedure TChatService.Join(const pseudo: string;
+  const callback: IChatCallback);
+begin
+  InterfaceArrayAdd(fConnected,callback);
+end;
+
+procedure TChatService.BlaBla(const pseudo,msg: string);
+var i: integer;
+begin
+  for i := high(fConnected) downto 0 do // downwards for InterfaceArrayDelete()
+    try
+      fConnected[i].NotifyBlaBla(pseudo,msg);
+    except
+      InterfaceArrayDelete(fConnected,i); // unsubscribe the callback on failure
+    end;
+end;
+
+procedure TChatService.CallbackReleased(const callback: IInvokable; const interfaceName: RawUTF8);
+begin
+  if interfaceName='IChatCallback' then
+    InterfaceArrayDelete(fConnected,callback);
+end;
+
+
+procedure Run;
+var HttpServer: TSQLHttpServer;
+    Server: TSQLRestServerFullMemory;
+begin
+  Server := TSQLRestServerFullMemory.CreateWithOwnModel([]);
+  try
+    Server.CreateMissingTables;
+    Server.ServiceDefine(TChatService,[IChatService],sicShared).
+      SetOptions([],[optExecLockedPerInterface]). // thread-safe fConnected[]
+      ByPassAuthentication := true;
+    HttpServer := TSQLHttpServer.Create('8888',[Server],'+',useBidirSocket);
+    try
+      HttpServer.WebSocketsEnable(Server,PROJECT31_TRANSMISSION_KEY).
+        Settings.SetFullLog; // full verbose logs for this demo
+      TextColor(ccLightGreen);
+      writeln('WebSockets Chat Server running on localhost:8888'#13#10);
+      TextColor(ccWhite);
+      writeln('Please compile and run Project31ChatClient.exe'#13#10);
+      TextColor(ccLightGray);
+      writeln('Press [Enter] to quit'#13#10);
+      TextColor(ccCyan);
+      readln;
+    finally
+      HttpServer.Free;
+    end;
+  finally
+    Server.Free;
+  end;
+end;
+
+
+begin
+  with TSQLLog.Family do begin // enable logging to file and to console
+    Level := LOG_VERBOSE;
+    EchoToConsole := LOG_VERBOSE;
+    PerThreadLog := ptIdentifiedInOnFile;
+  end;
+  WebSocketLog := TSQLLog; // verbose log of all WebSockets activity
+  try
+    Run;
+  except
+    on E: Exception do
+      ConsoleShowFatalException(E);
+  end;
+end.

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31LongWorkCallbackInterface.pas

@@ -0,0 +1,32 @@
+unit Project31LongWorkCallbackInterface;
+
+interface
+
+uses
+  SysUtils,
+  SynCommons,
+  mORMot;
+
+type
+  ILongWorkCallback = interface(IInvokable)
+    ['{425BF199-19C7-4B2B-B1A4-A5BE7A9A4748}']
+    procedure WorkFinished(const workName: string; timeTaken: integer);
+    procedure WorkFailed(const workName, error: string);
+  end;
+  
+  ILongWorkService = interface(IInvokable)
+    ['{09FDFCEF-86E5-4077-80D8-661801A9224A}']
+    procedure StartWork(const workName: string; const onFinish: ILongWorkCallback);
+    function TotalWorkCount: Integer;
+  end;
+
+const
+  PROJECT31_TRANSMISSION_KEY = 'longwork_privatekey';
+
+  
+implementation
+
+initialization
+  TInterfaceFactory.RegisterInterfaces([
+    TypeInfo(ILongWorkService),TypeInfo(ILongWorkCallback)]);
+end.

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31LongWorkClient.dpr

@@ -0,0 +1,91 @@
+/// simple SOA client using a callback for long process ending notification
+program Project31LongWorkClient;
+
+uses
+  {$I SynDprUses.inc} // use FastMM4 on older versions of Delphi
+  SysUtils,
+  Classes,
+  SynCommons,
+  SynTable,
+  mORMot,
+  mORMotHttpClient,
+  Project31LongWorkCallbackInterface in 'Project31LongWorkCallbackInterface.pas';
+
+{$APPTYPE CONSOLE}
+
+type
+  TLongWorkCallback = class(TInterfacedCallback,ILongWorkCallback)
+  protected
+    procedure WorkFinished(const workName: string; timeTaken: integer);
+    procedure WorkFailed(const workName, error: string);
+  end;
+
+procedure TLongWorkCallback.WorkFailed(const workName, error: string);
+begin
+  TextColor(ccLightRed);
+  writeln(#13'Received callback WorkFailed(',workName,') with message "',error,'"');
+  TextColor(ccLightGray);
+  write('>');
+end;
+
+procedure TLongWorkCallback.WorkFinished(const workName: string;
+  timeTaken: integer);
+begin
+  TextColor(ccLightBlue);
+  writeln(#13'Received callback WorkFinished(',workName,') in ',timeTaken,'ms');
+  TextColor(ccLightGray);
+  write('>');
+end;
+
+
+procedure Run;
+var Client: TSQLHttpClientWebsockets;
+    workName: string;
+    Service: ILongWorkService;
+    callback: ILongWorkCallback;
+begin
+  writeln('Connecting to the local Websockets server...');
+  Client := TSQLHttpClientWebsockets.Create('127.0.0.1','8888',TSQLModel.Create([]));
+  try
+    Client.Model.Owner := Client;
+    Client.WebSocketsUpgrade(PROJECT31_TRANSMISSION_KEY);
+    if not Client.ServerTimeStampSynchronize then
+      raise EServiceException.Create(
+        'Error connecting to the server: please run Project31LongWorkServer.exe');
+    Client.ServiceDefine([ILongWorkService],sicShared);
+    if not Client.Services.Resolve(ILongWorkService,Service) then
+      raise EServiceException.Create('Service ILongWorkService unavailable');
+    TextColor(ccWhite);
+    writeln('Please type a work name, then press [Enter]');
+    writeln('Enter a void line to quit');
+    callback := TLongWorkCallback.Create(Client,ILongWorkCallback);
+    try
+      repeat
+        TextColor(ccLightGray);
+        write('>');
+        readln(workName);
+        if workName='' then
+          break;
+        Service.StartWork(workName,callback);
+        TextColor(ccBrown);
+        writeln('Service.TotalWorkCount=',Service.TotalWorkCount);
+      until false;
+    finally
+      callback := nil;
+      Service := nil; // release the service local instance BEFORE Client.Free
+    end;
+  finally
+    Client.Free;
+  end;
+end;
+
+
+
+begin
+  try
+    Run;
+  except
+    on E: Exception do
+      ConsoleShowFatalException(E);
+  end;
+end.

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31LongWorkServer.dpr

@@ -0,0 +1,112 @@
+/// simple SOA server using a callback for long process ending notification
+program Project31LongWorkServer;
+
+uses
+  {$I SynDprUses.inc} // use FastMM4 on older versions of Delphi
+  SysUtils,
+  Classes,
+  SynCommons,
+  SynTable,
+  SynLog,
+  mORMot,
+  SynBidirSock,
+  mORMotHttpServer,
+  Project31LongWorkCallbackInterface in 'Project31LongWorkCallbackInterface.pas';
+
+{$APPTYPE CONSOLE}
+
+type
+  TLongWorkServiceThread = class(TThread)
+  protected
+    fCallback: ILongWorkCallback;
+    fWorkName: string;
+    procedure Execute; override;
+  public
+    constructor Create(const workName: string; const callback: ILongWorkCallback);
+  end;
+
+  TLongWorkService = class(TInterfacedObject,ILongWorkService)
+  protected
+    fTotalWorkCount: Integer;
+  public
+    procedure StartWork(const workName: string; const onFinish: ILongWorkCallback);
+    function TotalWorkCount: Integer;
+  end;
+
+procedure TLongWorkService.StartWork(const workName: string;
+  const onFinish: ILongWorkCallback);
+begin
+  InterlockedIncrement(fTotalWorkCount);
+  TLongWorkServiceThread.Create(workName,onFinish);
+end;
+
+function TLongWorkService.TotalWorkCount: Integer;
+begin
+  result := fTotalWorkCount;
+end;
+
+constructor TLongWorkServiceThread.Create(const workName: string;
+  const callback: ILongWorkCallback);
+begin
+  inherited Create(false);
+  fCallback := Callback;
+  fWorkName := workName;
+  FreeOnTerminate := true;
+end;
+
+procedure TLongWorkServiceThread.Execute;
+var tix: Int64;
+begin
+  TSQLLog.Add.Log(sllInfo,'%.Execute(%) started',[self,fWorkName]);
+  tix := GetTickCount64;
+  Sleep(5000+Random(1000)); // some hard work
+  if Random(100)>20 then
+    fCallback.WorkFinished(fWorkName,GetTickCount64-tix) else
+    fCallback.WorkFailed(fWorkName,'expected random failure');
+  TSQLLog.Add.Log(sllInfo,'%.Execute(%) notified',[self,fWorkName]);
+end;
+
+procedure Run;
+var HttpServer: TSQLHttpServer;
+    Server: TSQLRestServerFullMemory;
+begin
+  Server := TSQLRestServerFullMemory.CreateWithOwnModel([]);
+  try
+    Server.CreateMissingTables;
+    Server.ServiceDefine(TLongWorkService,[ILongWorkService],sicShared).
+      ByPassAuthentication := true;
+    HttpServer := TSQLHttpServer.Create('8888',[Server],'+',useBidirSocket);
+    try
+      HttpServer.WebSocketsEnable(Server,PROJECT31_TRANSMISSION_KEY).
+        Settings.SetFullLog; // full verbose logs for this demo
+      TextColor(ccLightGreen);
+      writeln('WebSockets Long Work Server running on localhost:8888'#13#10);
+      TextColor(ccWhite);
+      writeln('Please compile and run Project31LongWorkClient.exe'#13#10);
+      TextColor(ccLightGray);
+      writeln('Press [Enter] to quit'#13#10);
+      TextColor(ccCyan);
+      readln;
+    finally
+      HttpServer.Free;
+    end;
+  finally
+    Server.Free;
+  end;
+end;
+
+
+begin
+  with TSQLLog.Family do begin // enable logging to file and to console
+    Level := LOG_VERBOSE;
+    EchoToConsole := LOG_VERBOSE;
+    PerThreadLog := ptIdentifiedInOnFile;
+  end;
+  WebSocketLog := TSQLLog; // verbose log of all WebSockets activity
+  try
+    Run;
+  except
+    on E: Exception do
+      ConsoleShowFatalException(E);
+  end;
+end.

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31SimpleEchoServer.dpr

@@ -0,0 +1,70 @@
+/// simple Echo server using WebSockets
+program Project31SimpleEchoServer;
+
+uses
+  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
+  SysUtils,
+  SynCommons,
+  SynTable,
+  SynCrtSock,
+  SynBidirSock;
+
+{$APPTYPE CONSOLE}
+
+type
+  TWebSocketProtocolEcho = class(TWebSocketProtocolChat)
+  protected
+    procedure EchoFrame(Sender: THttpServerResp; const Frame: TWebSocketFrame);
+  end;
+
+procedure TWebSocketProtocolEcho.EchoFrame(Sender: THttpServerResp;
+  const Frame: TWebSocketFrame);
+begin
+  TextColor(ccLightMagenta);
+  write(GetEnumName(TypeInfo(TWebSocketFrameOpCode),ord(Frame.opcode))^,' - ');
+  TextColor(ccWhite);
+  case Frame.opcode of
+  focContinuation:
+    write('Connected');
+  focConnectionClose:
+    write('Disconnected');
+  focText,focBinary: begin
+    write('Echoing ',length(Frame.payload),' bytes');
+    SendFrame(Sender,Frame);
+  end;
+  end;
+  TextColor(ccCyan);
+  writeln(' from ',Sender.ServerSock.RemoteIP,'/',PtrInt(Sender.ServerSock.Sock));
+end;
+
+procedure Run;                   
+var Server: TWebSocketServer;
+    protocol: TWebSocketProtocolEcho;
+begin
+  Server := TWebSocketServer.Create('8888',nil,nil,'test');
+  try
+    protocol := TWebSocketProtocolEcho.Create('meow','');
+    protocol.OnIncomingFrame := protocol.EchoFrame;
+    Server.WebSocketProtocols.Add(protocol);
+    TextColor(ccLightGreen);
+    writeln('WebSockets Chat Server running on localhost:8888'#13#10);
+    TextColor(ccWhite);
+    writeln('Please load Project31SimpleEchoServer.html in your browser'#13#10);
+    TextColor(ccLightGray);
+    writeln('Press [Enter] to quit'#13#10);
+    TextColor(ccCyan);
+    readln;
+  finally
+    Server.Free;
+  end;
+end;
+
+
+begin
+  try
+    Run;
+  except
+    on E: Exception do
+      ConsoleShowFatalException(E);
+  end;
+end.

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31SimpleEchoServer.html

@@ -0,0 +1,82 @@
+<html>
+<head>
+<title>WebSockets Echo mORMot Sample 31</title>
+
+<style>
+ html,body{font:normal 0.9em arial,helvetica;}
+ #log {width:440px; height:200px; border:1px solid #7F9DB9; overflow:auto;}
+ #msg {width:330px;}
+</style>
+
+<script>
+var socket;
+
+function init(){
+  try
+  {
+    socket = new WebSocket("ws://localhost:8888/whatever/","meow");
+    // socket = new WebSocket("ws://localhost:8888",""); // will also work
+    log('WebSocket - status '+socket.readyState);
+    socket.onopen    = function(msg){ console.log(msg); log("onopen: Welcome - status "+this.readyState); };
+    socket.onmessage = function(msg){ console.log(msg); log("onmessage: ("+msg.data.length+" bytes): " + (msg.data.length < 5000 ? msg.data : (msg.data.substr(0, 30) + '...'))); };
+    socket.onerror   = function(msg){ console.log(msg); log("onerror - code:" + msg.code + ", reason:" + msg.reason + ", wasClean:" + msg.wasClean + ", status:" + this.readyState); };
+    socket.onclose   = function(msg){ console.log(msg); log("onclose - code:" + msg.code + ", reason:" + msg.reason + ", wasClean:" + msg.wasClean + ", status:" + this.readyState); };
+  }
+  catch(ex)
+  {
+    log(ex);
+  }
+  $("msg").focus();
+}
+
+function send(){
+  var txt,msg;
+  txt = $("msg");
+  msg = txt.value;
+  if(!msg){ alert("Message can not be empty"); return; }
+  txt.value="";
+  txt.focus();
+  try{ socket.send(msg); log('Sent ('+msg.length+" bytes): " + msg.length < 5000 ? msg : (msg.substr(0, 30) + '...')); } catch(ex){ log(ex); }
+}
+
+String.prototype.repeat = function(num)
+{
+  return new Array(num + 1).join(this);
+}
+
+function med(){
+  var msg;
+  msg = "med".repeat(2024);
+  try{ socket.send(msg); log('Sent ('+msg.length+" bytes): "); } catch(ex){ log(ex); }
+}
+
+function big(){
+  var msg;
+  msg = "a".repeat(1024 * 1024);
+  try{ socket.send(msg); log('Sent ('+msg.length+" bytes): "); } catch(ex){ log(ex); }
+}
+
+function quit(){
+  socket.close(1000, 'Bye bye');
+  socket=null;
+}
+
+// Utilities
+function $(id){ return document.getElementById(id); }
+function log(msg){ $("log").innerHTML+="<br>"+msg; }
+function onkey(event){ if(event.keyCode==13){ send(); } }
+</script>
+
+</head>
+<body onload="init()">
+ <h3>WebSocket Test</h3>
+ <p>Please run Project31SimpleEchoServer or Project31WinHTTPEchoServer on this computer!</p>
+ <div id="log"></div>
+ <input id="msg" type="textbox" onkeypress="onkey(event)"/>
+ <button onclick="send()">Send</button>
+ <button onclick="med()">6KB Msg</button>
+ <button onclick="big()">1MB Msg</button>
+ <button onclick="quit()">Quit</button>
+ <div>Server will echo your response!</div>
+</body>
+</html>

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31WinHTTPEchoServer.dpr

@@ -0,0 +1,165 @@
+program Project31WinHTTPEchoServer;
+
+{$I Synopse.inc}
+
+{$APPTYPE CONSOLE}
+
+uses
+  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
+  SysUtils,
+  SynZip,
+  SynCrtSock,
+  SynCommons,
+  SynTable;
+
+type
+  TSimpleWebsocketServer = class
+  private
+    fServer: THttpApiWebSocketServer;
+//    fProtocols: THttpApiWebSocketServerProtocolDynArray;
+    function onHttpRequest(Ctxt: THttpServerRequest): cardinal;
+    function onAccept(Ctxt: THttpServerRequest; var Conn: THttpApiWebSocketConnection): Boolean;
+    procedure onConnect(const Conn: THttpApiWebSocketConnection );
+    procedure onMessage(const Conn: THttpApiWebSocketConnection; aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: Cardinal);
+    procedure onDisconnect(const Conn: THttpApiWebSocketConnection ; aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: Cardinal);
+  public
+    constructor Create;
+    destructor Destroy; override;
+  end;
+{ TSimpleWebsocketServer }
+
+constructor TSimpleWebsocketServer.Create;
+begin
+  fServer := THttpApiWebSocketServer.Create(false, 8, 10000);
+  fServer.AddUrl('','8888', False, 'localhost');
+  fServer.AddUrlWebSocket('whatever', '8888', False, 'localhost');
+  // ManualFragmentManagement = false - so Server will join all packet fragments
+  // automatically and call onMessage with full message content
+  fServer.RegisterProtocol('meow', False, onAccept, onMessage, onConnect, onDisconnect);
+  fServer.RegisterCompress(CompressDeflate);
+  fServer.OnRequest := onHttpRequest;
+  fServer.Clone(8);
+end;
+
+destructor TSimpleWebsocketServer.Destroy;
+begin
+  fServer.Free;
+  inherited;
+end;
+
+function TSimpleWebsocketServer.onAccept(Ctxt: THttpServerRequest; var Conn: THttpApiWebSocketConnection): Boolean;
+begin
+// You can check some Ctxt parameters here
+  Result := true;
+end;
+
+procedure TSimpleWebsocketServer.onConnect(const Conn: THttpApiWebSocketConnection);
+begin
+  Writeln('New connection. Assigned connectionID=', Conn.index);
+end;
+
+procedure TSimpleWebsocketServer.onDisconnect(const Conn: THttpApiWebSocketConnection;
+  aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: Cardinal);
+var
+  str: RawUTF8;
+begin
+  SetString(str, pUtf8Char(aBuffer), aBufferSize);
+
+  Writeln('Disconnected ', Conn.index,' ',aStatus,' ',str);
+end;
+
+function TSimpleWebsocketServer.onHttpRequest(Ctxt: THttpServerRequest): cardinal;
+begin
+  Writeln('HTTP request to ', Ctxt.URL);
+  if Ctxt.URL = '/' then
+    Ctxt.OutContent := 'Project31SimpleEchoServer.html'
+  else if Ctxt.URL = '/favicon.ico' then
+     Ctxt.OutContent := 'favicon.ico';
+  Ctxt.OutContentType := HTTP_RESP_STATICFILE;
+  Result := 200;
+end;
+
+procedure TSimpleWebsocketServer.onMessage(const Conn: THttpApiWebSocketConnection;
+  aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: Cardinal);
+var
+  str: RawUTF8;
+begin
+  Conn.Send(aBufferType, aBuffer, aBufferSize);
+//  Conn.Protocol.Send(Conn.index, aBufferType, aBuffer, aBufferSize); //also work
+  SetString(str, pUtf8Char(aBuffer), aBufferSize);
+  if aBufferType = WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE then
+    Writeln('UTF8 message from ', Conn.index, ': ',str)
+  else if aBufferType = WEB_SOCKET_UTF8_FRAGMENT_BUFFER_TYPE then
+    Writeln('UTF8 fragment from ', Conn.index, ': ',str)
+  else if (aBufferType = WEB_SOCKET_BINARY_MESSAGE_BUFFER_TYPE)
+    or (aBufferType = WEB_SOCKET_BINARY_FRAGMENT_BUFFER_TYPE) then
+    Writeln(aBufferType, ' from ', Conn.index, ' of length ', aBufferSize)
+  else begin
+    Writeln(aBufferType, ' from ', Conn.index, ': ',str);
+  end;
+end;
+
+var
+  _Server: TSimpleWebsocketServer;
+  s: string;
+  idx: integer;
+  MsgBuffer: RawUTF8;
+  CloseReasonBuffer: RawUTF8;
+begin
+  MsgBuffer := '';
+  CloseReasonBuffer := 'Connection closed by server';
+  try
+    _Server := TSimpleWebsocketServer.Create;
+    try
+      Writeln('WebSocket server is now listen on ws://localhost:8888/whatever');
+      Writeln('HTTP server is now listen on http://localhost:8888/');
+      Writeln(' Point your browser to http://localhost:8888/ for initial page');
+      WriteLn('Type one of a commnad:');
+      Writeln(' - "close connectionID" to close existing webSocket connection');
+      Writeln(' - "sendto connectionID" to send text to specified WebCocket');
+      Writeln(' - "sendall" to send text to specified WebCocket');
+      Writeln(' - press [Enter] to quit');
+      Writeln('Waiting for command:');
+      repeat
+        Readln(s);
+        if Pos('close ', s) = 1 then begin
+          s := SysUtils.Trim(Copy(s, 7, Length(s)));
+          _Server.fServer.Protocols[0].Close(StrToIntDef(s, -1), WEB_SOCKET_SUCCESS_CLOSE_STATUS,
+            Pointer(CloseReasonBuffer), length(CloseReasonBuffer));
+        end else if Pos('sendto ', s) = 1 then begin
+          s := SysUtils.Trim(Copy(s, 8, Length(s)));
+          idx := StrToIntDef(s, -1);
+          if (idx = -1 ) then
+            Writeln('Invalid connection ID. Usage: send connectionID (Example: send 0)')
+          else begin
+            Write('Type text to send: ');
+            Readln(MsgBuffer);
+            if _Server.fServer.Protocols[0].Send(
+              StrToIntDef(s, -1), WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE,
+              Pointer(MsgBuffer), length(MsgBuffer)
+            ) then
+              WriteLn('Sent successfully. The message should appear in the client. Waiting for command:')
+            else
+              WriteLn('Error')
+          end;
+        end else if (s = 'sendall') then begin
+          Write('Type text to send: ');
+          Readln(MsgBuffer);
+          if _Server.fServer.Protocols[0].Broadcast(
+            WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE,
+            Pointer(MsgBuffer), length(MsgBuffer)
+          ) then
+            WriteLn('Broadcast successfully. All clients should got a message. Waiting for command:')
+          else
+            WriteLn('Error')
+        end else if (s <> '') then
+          WriteLn('Invalid comand; Valid command are: close, sendto, sendall');
+      until s = '';
+    finally
+      _Server.Free;
+    end;
+  except
+    on E: Exception do
+      Writeln(E.ClassName, ': ', E.Message);
+  end;
+end.

contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31WinHTTPEchoServer.lpi

@@ -0,0 +1,71 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <General>
+      <Flags>
+        <MainUnitHasUsesSectionForAllUnits Value="False"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="Project31WinHTTPEchoServer"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+      <Modes Count="1">
+        <Mode0 Name="default"/>
+      </Modes>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="Project31WinHTTPEchoServer.dpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <SearchPaths>
+      <IncludeFiles Value="..\..\..;$(ProjOutDir)"/>
+      <OtherUnitFiles Value="..\..\.."/>
+    </SearchPaths>
+    <Parsing>
+      <SyntaxOptions>
+        <SyntaxMode Value="Delphi"/>
+      </SyntaxOptions>
+    </Parsing>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>