freepascal.compiler/packages/fcl-web/examples/websocket/server/wsserver.lpr

program wsserver;

uses
  {$ifdef unix} cthreads, cwstring, {$endif}
  custapp, sysutils, jsonparser, fpjson, syncobjs, classes,
  fpwebsocket, fpwebsocketclient, fpwebsocketserver, fpcustwsserver, wschat;

Type

  { TWSApp }

  TWSApp = class(TCustomApplication)
  private
    FSrv : TWebSocketServer;
    FChat : TWebsocketChat;
    procedure DoChatLog(Sender: TObject; const Msg: String);
  Public
    constructor create(aOwner : TComponent); override;
    destructor destroy; override;
    procedure DoRun; override;
  end;

{ TWSApp }

procedure TWSApp.DoChatLog(Sender: TObject; const Msg: String);
begin
  Writeln(Msg);
end;

constructor TWSApp.create(aOwner: TComponent);
begin
  inherited create(aOwner);
  FSrv:=TWebSocketServer.Create(Self);
  FChat:=TWebsocketChat.Create(Self);
  FChat.WebsocketServer:=FSrv;
  FChat.OnLog:=@DoChatLog;
  // Must do this here, because the events are protected
  FSrv.OnMessageReceived:[email protected];
  FSrv.OnControlReceived:[email protected];
  FSrv.OnDisconnect:[email protected];
end;

destructor TWSApp.destroy;
begin
  FreeAndNil(FChat);
  FreeAndNil(FSrv);
  inherited destroy;
end;


procedure TWSApp.DoRun;


begin
  CheckOptions('p:t:ahw:i:m:',['port:','threadmode','accept-threaded','wait:','idle:','mask:']);
  case GetOptionValue('t','threadmode') of
    'pool'   : FSrv.ThreadMode:=wtmThreadPool;
    'thread' : FSrv.ThreadMode:=wtmThread;
    'none'   : FSrv.ThreadMode:=wtmNone;
  else
    FSrv.ThreadMode:=wtmThread;
  end;
  // Will not return till stopped.
  FSrv.ThreadedAccept:=HasOption('a','accept-threaded');
  if HasOption('w','wait') then
    FSrv.MessageWaitTime:=StrToIntDef(GetOptionValue('w','wait'),DefaultWaitTime);
  if HasOption('i','idle') then
    FSrv.AcceptIdleTimeout:=StrToIntDef(GetOptionValue('i','idle'),DefaultAcceptTimeout);
  FSrv.Active:=True;
  FSrv.OutgoingFrameMask:=StrToIntDef(GetOptionValue('m','mask'),0);
  if Not FSrv.ThreadedAccept then
    Terminate
  else
    While Not Terminated do
      Sleep(10);
end;

begin
  With TWSApp.Create(Nil) do
    try
      Initialize;
      Run;
    finally
      Free;
    end;
end.