cmueller/DelphiWebsockets
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Compare commits

base: cmueller:master
Branches Tags
cmueller:master
cmueller:master-Yvi71-pull
cmueller:main-SSL-support
..
compare: cmueller:main-SSL-support
Branches Tags
cmueller:master
cmueller:master-Yvi71-pull
cmueller:main-SSL-support

2 commits
master ... main-SSL-s

Author SHA1 Message Date
Administrator
ffc090df44 better error handling, added DefaultErrorCallback 2015-11-16 10:45:56 +01:00
Administrator
69d3f52ab4 SSL support (seperated websocket implementation from IOHandler to an proxy object) 2015-11-16 10:44:39 +01:00
12 changed files with 917 additions and 1040 deletions
Show stats Expand all files Collapse all files

2
DUnit/UnitTestWebsockets.dpr
View file

@ -14,7 +14,7 @@ program UnitTestWebsockets;
{$APPTYPE CONSOLE}
{$ENDIF}
//{$IFNDEF USE_JEDI_JCL} {$MESSAGE ERROR 'Must define "USE_JEDI_JCL" for location info of errors'} {$ENDIF}
{$IFNDEF USE_JEDI_JCL} {$MESSAGE ERROR 'Must define "USE_JEDI_JCL" for location info of errors'} {$ENDIF}
{$R *.RES}

14
DUnit/mtTestWebSockets.pas
View file

@ -156,7 +156,7 @@ begin
//* client to server */
received := '';
IndyHTTPWebsocketServer1.SocketIO.OnEvent('TEST_EVENT',
procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: ISocketIOCallback)
procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: TSocketIOCallbackObj)
begin
received := aArgument.ToJson;
end);
@ -180,7 +180,7 @@ begin
//* server to client */
received := '';
IndyHTTPWebsocketClient1.SocketIO.OnEvent('TEST_EVENT',
procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: ISocketIOCallback)
procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: TSocketIOCallbackObj)
begin
received := aArgument.ToJson;
end);
@ -205,12 +205,12 @@ begin
//* client to server */
FLastSocketIOMsg := '';
IndyHTTPWebsocketServer1.SocketIO.OnSocketIOMsg :=
procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: ISocketIOCallback)
procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj)
begin
Abort;
end;
IndyHTTPWebsocketClient1.SocketIO.Send('test message',
procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: ISocketIOCallback)
procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: TSocketIOCallbackObj)
begin
FLastSocketIOMsg := aJSON.AsString;
end);
@ -223,7 +223,7 @@ begin
FLastSocketIOMsg := '';
IndyHTTPWebsocketClient1.SocketIO.Send('test message',
procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: ISocketIOCallback)
procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: TSocketIOCallbackObj)
begin
Assert(False, 'should go to error handling callback');
FLastSocketIOMsg := 'error';
@ -252,7 +252,7 @@ begin
//* client to server */
FLastSocketIOMsg := '';
IndyHTTPWebsocketServer1.SocketIO.OnSocketIOMsg :=
procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: ISocketIOCallback)
procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj)
begin
FLastSocketIOMsg := aText;
end;
@ -267,7 +267,7 @@ begin
//* server to client */
FLastSocketIOMsg := '';
IndyHTTPWebsocketClient1.SocketIO.OnSocketIOMsg :=
procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: ISocketIOCallback)
procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: TSocketIOCallbackObj)
begin
FLastSocketIOMsg := aText;
end;

561
IdHTTPWebsocketClient.pas
View file

@ -1,15 +1,25 @@
unit IdHTTPWebsocketClient;
interface
{$I wsdefines.pas}
uses
Classes,
IdHTTP,
{$IF CompilerVersion <= 21.0} //D2010
IdHashSHA1,
{$else}
Types,
IdHashSHA, //XE3 etc
{$IFEND}
IdIOHandler,
IdIOHandlerWebsocket,
// {$ifdef FMX}
// FMX.Types,
// {$ELSE}
// ExtCtrls,
// {$ENDIF}
IdWinsock2, Generics.Collections, SyncObjs,
IdSocketIOHandling;
IdSocketIOHandling, IdIOHandlerStack;
type
TWebsocketMsgBin = procedure(const aData: TStream) of object;
@ -29,11 +39,14 @@ type
FOnTextData: TWebsocketMsgText;
FNoAsyncRead: Boolean;
FWriteTimeout: Integer;
function GetIOHandlerWS: TIdIOHandlerWebsocket;
procedure SetIOHandlerWS(const Value: TIdIOHandlerWebsocket);
FUseSSL: boolean;
FWebsocketImpl: TWebsocketImplementationProxy;
function GetIOHandlerWS: TWebsocketImplementationProxy;
procedure SetOnData(const Value: TWebsocketMsgBin);
procedure SetOnTextData(const Value: TWebsocketMsgText);
procedure SetWriteTimeout(const Value: Integer);
function GetIOHandler: TIdIOHandlerStack;
procedure SetIOHandlerStack(const Value: TIdIOHandlerStack);
protected
FSocketIOCompatible: Boolean;
FSocketIOHandshakeResponse: string;
@ -71,7 +84,8 @@ type
procedure Ping;
procedure ReadAndProcessData;
property IOHandler: TIdIOHandlerWebsocket read GetIOHandlerWS write SetIOHandlerWS;
property IOHandler: TIdIOHandlerStack read GetIOHandler write SetIOHandlerStack;
property IOHandlerWS: TWebsocketImplementationProxy read GetIOHandlerWS; // write SetIOHandlerWS;
//websockets
property OnBinData : TWebsocketMsgBin read FOnData write SetOnData;
@ -86,43 +100,11 @@ type
property Host;
property Port;
property WSResourceName: string read FWSResourceName write FWSResourceName;
property UseSSL: boolean read FUseSSL write FUseSSL;
property WriteTimeout: Integer read FWriteTimeout write SetWriteTimeout default 2000;
end;
// on error
(*
TIdHTTPSocketIOClient_old = class(TIdHTTPWebsocketClient)
private
FOnConnected: TNotifyEvent;
FOnDisConnected: TNotifyEvent;
FOnSocketIOMsg: TSocketIOMsg;
FOnSocketIOEvent: TSocketIOMsg;
FOnSocketIOJson: TSocketIOMsg;
protected
FHeartBeat: TTimer;
procedure HeartBeatTimer(Sender: TObject);
procedure InternalUpgradeToWebsocket(aRaiseException: Boolean; out aFailedReason: string);override;
public
procedure AsyncDispatchEvent(const aEvent: string); override;
public
procedure AfterConstruction; override;
destructor Destroy; override;
procedure AutoConnect;
property SocketIOHandshakeResponse: string read FSocketIOHandshakeResponse;
property OnConnected: TNotifyEvent read FOnConnected write FOnConnected;
property OnDisConnected: TNotifyEvent read FOnDisConnected write FOnDisConnected;
// procedure ProcessSocketIORequest(const strmRequest: TStream);
property OnSocketIOMsg : TSocketIOMsg read FOnSocketIOMsg write FOnSocketIOMsg;
property OnSocketIOJson : TSocketIOMsg read FOnSocketIOJson write FOnSocketIOJson;
property OnSocketIOEvent: TSocketIOMsg read FOnSocketIOEvent write FOnSocketIOEvent;
end;
*)
TWSThreadList = class(TThreadList)
public
function Count: Integer;
@ -181,35 +163,6 @@ uses
var
GUnitFinalized: Boolean = false;
//type
// TAnonymousThread = class(TThread)
// protected
// FThreadProc: TThreadProcedure;
// procedure Execute; override;
// public
// constructor Create(AThreadProc: TThreadProcedure);
// end;
//procedure CreateAnonymousThread(AThreadProc: TThreadProcedure);
//begin
// TAnonymousThread.Create(AThreadProc);
//end;
{ TAnonymousThread }
//constructor TAnonymousThread.Create(AThreadProc: TThreadProcedure);
//begin
// FThreadProc := AThreadProc;
// FreeOnTerminate := True;
// inherited Create(False {direct start});
//end;
//
//procedure TAnonymousThread.Execute;
//begin
// if Assigned(FThreadProc) then
// FThreadProc();
//end;
{ TIdHTTPWebsocketClient }
procedure TIdHTTPWebsocketClient.AfterConstruction;
@ -217,9 +170,9 @@ begin
inherited;
FHash := TIdHashSHA1.Create;
IOHandler := TIdIOHandlerWebsocket.Create(nil);
IOHandler.UseNagle := False;
ManagedIOHandler := True;
//IOHandler := TIdIOHandlerWebsocket.Create(nil);
//IOHandler.RealIOHandler.UseNagle := False;
//ManagedIOHandler := True;
FSocketIO := TIdSocketIOHandling_Ext.Create;
// FHeartBeat := TTimer.Create(nil);
@ -316,7 +269,7 @@ begin
else
begin
//clear inputbuffer, otherwise it can't connect :(
if (IOHandler <> nil) then IOHandler.Clear;
if (IOHandlerWS <> nil) then IOHandlerWS.Clear;
inherited Connect;
end;
finally
@ -341,7 +294,8 @@ begin
// tmr.Free;
// end);
TIdWebsocketMultiReadThread.Instance.RemoveClient(Self);
//TIdWebsocketMultiReadThread.Instance.RemoveClient(Self);
DisConnect(True);
FSocketIO.Free;
FHash.Free;
inherited;
@ -350,7 +304,7 @@ end;
procedure TIdHTTPWebsocketClient.DisConnect(ANotifyPeer: Boolean);
begin
if not SocketIOCompatible and
( (IOHandler <> nil) and not IOHandler.IsWebsocket)
( (IOHandlerWS <> nil) and not IOHandlerWS.IsWebsocket)
then
TIdWebsocketMultiReadThread.Instance.RemoveClient(Self);
@ -366,18 +320,19 @@ begin
try
if IOHandler <> nil then
begin
IOHandler.Lock;
IOHandlerWS.Lock;
try
IOHandler.IsWebsocket := False;
IOHandlerWS.IsWebsocket := False;
Self.ManagedIOHandler := False; //otherwise it gets freed while we have a lock on it...
inherited DisConnect(ANotifyPeer);
//clear buffer, other still "connected"
IOHandler.Clear;
IOHandlerWS.Clear;
//IOHandler.Free;
//IOHandler := TIdIOHandlerWebsocket.Create(nil);
finally
IOHandler.Unlock;
IOHandlerWS.Unlock;
end;
end;
finally
@ -385,12 +340,25 @@ begin
end;
end;
function TIdHTTPWebsocketClient.GetIOHandlerWS: TIdIOHandlerWebsocket;
function TIdHTTPWebsocketClient.GetIOHandler: TIdIOHandlerStack;
begin
// if inherited IOHandler is TIdIOHandlerWebsocket then
Result := inherited IOHandler as TIdIOHandlerWebsocket
// else
// Assert(False);
Result := inherited IOHandler as TIdIOHandlerStack;
if Result = nil then
begin
inherited IOHandler := MakeImplicitClientHandler;
Result := inherited IOHandler as TIdIOHandlerStack;
end;
end;
function TIdHTTPWebsocketClient.GetIOHandlerWS: TWebsocketImplementationProxy;
begin
if FWebsocketImpl = nil then
begin
inherited IOHandler := Self.MakeImplicitClientHandler;
Assert(FWebsocketImpl <> nil);
end;
Result := FWebsocketImpl;
end;
function TIdHTTPWebsocketClient.GetSocketIO: TIdSocketIOHandling;
@ -398,59 +366,6 @@ begin
Result := FSocketIO;
end;
(*
procedure TIdHTTPWebsocketClient.HeartBeatTimer(Sender: TObject);
begin
FHeartBeat.Enabled := False;
FSocketIO.Lock;
try
try
if (IOHandler <> nil) and
not IOHandler.ClosedGracefully and
IOHandler.Connected and
(FSocketIOContext <> nil) then
begin
FSocketIO.WritePing(FSocketIOContext as TSocketIOContext); //heartbeat socket.io message
end
//retry re-connect
else
try
//clear inputbuffer, otherwise it can't connect :(
if (IOHandler <> nil) then
IOHandler.Clear;
Self.ConnectTimeout := 100; //100ms otherwise GUI hangs too much -> todo: do it in background thread!
if not Connected then
Self.Connect;
TryUpgradeToWebsocket;
except
//skip, just retried
end;
except on E:Exception do
begin
//clear inputbuffer, otherwise it stays connected :(
if (IOHandler <> nil) then
IOHandler.Clear;
Disconnect(False);
if Assigned(OnDisConnected) then
OnDisConnected(Self);
try
raise EIdException.Create('Connection lost from ' +
Format('ws://%s:%d/%s', [Host, Port, WSResourceName]) +
' - Error: ' + e.Message);
except
//eat, no error popup!
end;
end;
end;
finally
FSocketIO.UnLock;
FHeartBeat.Enabled := True; //always enable: in case of disconnect it will re-connect
end;
end;
*)
function TIdHTTPWebsocketClient.TryConnect: Boolean;
begin
Lock;
@ -483,7 +398,7 @@ begin
FSocketIOConnectBusy := True;
Lock;
try
if (IOHandler <> nil) and IOHandler.IsWebsocket then Exit(True);
if (IOHandler <> nil) and IOHandlerWS.IsWebsocket then Exit(True);
InternalUpgradeToWebsocket(False{no raise}, sError);
Result := (sError = '');
@ -509,7 +424,7 @@ begin
try
if IOHandler = nil then
Connect
else if not IOHandler.IsWebsocket then
else if not IOHandlerWS.IsWebsocket then
InternalUpgradeToWebsocket(True{raise}, sError);
finally
UnLock;
@ -525,7 +440,7 @@ var
sSocketioextended: string;
bLocked: boolean;
begin
Assert((IOHandler = nil) or not IOHandler.IsWebsocket);
Assert((IOHandler = nil) or not IOHandlerWS.IsWebsocket);
//remove from thread during connection handling
TIdWebsocketMultiReadThread.Instance.RemoveClient(Self);
@ -536,10 +451,10 @@ begin
//reset pending data
if IOHandler <> nil then
begin
IOHandler.Lock;
IOHandlerWS.Lock;
bLocked := True;
if IOHandler.IsWebsocket then Exit;
IOHandler.Clear;
if IOHandlerWS.IsWebsocket then Exit;
IOHandlerWS.Clear;
end;
//special socket.io handling, see https://github.com/LearnBoost/socket.io-spec
@ -547,14 +462,17 @@ begin
begin
Request.Clear;
Request.Connection := 'keep-alive';
{$IFDEF WEBSOCKETSSL}
sURL := Format('https://%s:%d/socket.io/1/', [Host, Port]);
{$ELSE}
if UseSSL then
sURL := Format('https://%s:%d/socket.io/1/', [Host, Port])
else
sURL := Format('http://%s:%d/socket.io/1/', [Host, Port]);
{$ENDIF}
strmResponse.Clear;
ReadTimeout := 5 * 1000;
if DebugHook > 0 then
ReadTimeout := ReadTimeout * 10;
//get initial handshake
Post(sURL, strmResponse, strmResponse);
if ResponseCode = 200 {OK} then
@ -619,10 +537,15 @@ begin
//ws://host:port/<resourcename>
//about resourcename, see: http://dev.w3.org/html5/websockets/ "Parsing WebSocket URLs"
//sURL := Format('ws://%s:%d/%s', [Host, Port, WSResourceName]);
if UseSSL then
sURL := Format('https://%s:%d/%s', [Host, Port, WSResourceName])
else
sURL := Format('http://%s:%d/%s', [Host, Port, WSResourceName]);
ReadTimeout := Max(5 * 1000, ReadTimeout);
{ voorbeeld:
{ example:
GET http://localhost:9222/devtools/page/642D7227-148E-47C2-B97A-E00850E3AFA3 HTTP/1.1
Upgrade: websocket
Connection: Upgrade
@ -636,49 +559,8 @@ begin
User-Agent: Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/27.0.1453.116 Safari/537.36
Cookie: __utma=1.2040118404.1366961318.1366961318.1366961318.1; __utmc=1; __utmz=1.1366961318.1.1.utmcsr=(direct)|utmccn=(direct)|utmcmd=(none); deviceorder=0123456789101112; MultiTouchEnabled=false; device=3; network_type=0
}
if SocketIOCompatible then
begin
//1st, try to do socketio specific connection
Response.Clear;
Response.ResponseCode := 0;
Request.URL := sURL;
Request.Method := Id_HTTPMethodGet;
Request.Source := nil;
Response.ContentStream := strmResponse;
PrepareRequest(Request);
//connect and upgrade
ConnectToHost(Request, Response);
//check upgrade succesfull
CheckForGracefulDisconnect(True);
CheckConnected;
Assert(Self.Connected);
if Response.ResponseCode = 0 then
Response.ResponseText := Response.ResponseText
else if Response.ResponseCode <> 200{ok} then
begin
aFailedReason := Format('Error while upgrading: "%d: %s"',[ResponseCode, ResponseText]);
if aRaiseException then
raise EIdWebSocketHandleError.Create(aFailedReason)
else
Exit;
end;
//2nd, get websocket response
Response.Clear;
if IOHandler.CheckForDataOnSource(ReadTimeout) then
begin
Self.FHTTPProto.RetrieveHeaders(MaxHeaderLines);
//Response.RawHeaders.Text := IOHandler.InputBufferAsString();
Response.ResponseText := Response.RawHeaders.Text;
end;
end
else
begin
Get(sURL, strmResponse, [101]);
end;
//http://www.websocket.org/aboutwebsocket.html
(* HTTP/1.1 101 WebSocket Protocol Handshake
@ -692,9 +574,9 @@ begin
Access-Control-Allow-Headers: content-type *)
//'HTTP/1.1 101 Switching Protocols'
if Response.ResponseCode <> 101 then
if ResponseCode <> 101 then
begin
aFailedReason := Format('Error while upgrading: "%d: %s"',[Response.ResponseCode, Response.ResponseText]);
aFailedReason := Format('Error while upgrading: "%d: %s"',[ResponseCode, ResponseText]);
if aRaiseException then
raise EIdWebSocketHandleError.Create(aFailedReason)
else
@ -731,9 +613,10 @@ begin
else
Exit;
end;
end;
//upgrade succesful
IOHandler.IsWebsocket := True;
IOHandlerWS.IsWebsocket := True;
aFailedReason := '';
Assert(Connected);
@ -752,7 +635,7 @@ begin
strmResponse.Free;
if bLocked and (IOHandler <> nil) then
IOHandler.Unlock;
IOHandlerWS.Unlock;
Unlock;
//add to thread for auto retry/reconnect
@ -773,16 +656,27 @@ end;
function TIdHTTPWebsocketClient.MakeImplicitClientHandler: TIdIOHandler;
begin
Result := TIdIOHandlerWebsocket.Create(nil);
if UseSSL then
begin
Result := TIdIOHandlerWebsocketSSL.Create(nil);
FWebsocketImpl := (Result as TIdIOHandlerWebsocketSSL).WebsocketImpl;
end
else
begin
Result := TIdIOHandlerWebsocketPlain.Create(nil);
FWebsocketImpl := (Result as TIdIOHandlerWebsocketPlain).WebsocketImpl;
end;
(Result as TIdIOHandlerStack).UseNagle := False;
end;
procedure TIdHTTPWebsocketClient.Ping;
var
ws: TIdIOHandlerWebsocket;
ws: TWebsocketImplementationProxy;
begin
if TryLock then
try
ws := IOHandler as TIdIOHandlerWebsocket;
ws := IOHandlerWS;
ws.LastPingTime := Now;
//socket.io?
@ -818,10 +712,10 @@ var
wscode: TWSDataCode;
begin
strmEvent := nil;
IOHandler.Lock;
IOHandlerWS.Lock;
try
//try to process all events
while IOHandler.HasData or
while IOHandlerWS.HasData or
(IOHandler.Connected and
IOHandler.Readable(0)) do //has some data
begin
@ -861,7 +755,7 @@ begin
end;
end;
finally
IOHandler.Unlock;
IOHandlerWS.Unlock;
strmEvent.Free;
end;
end;
@ -875,8 +769,8 @@ begin
if IOHandler <> nil then
begin
IOHandler.InputBuffer.Clear;
IOHandler.BusyUpgrading := False;
IOHandler.IsWebsocket := False;
IOHandlerWS.BusyUpgrading := False;
IOHandlerWS.IsWebsocket := False;
//close/disconnect internal socket
//ws := IndyClient.IOHandler as TIdIOHandlerWebsocket;
//ws.Close; done in disconnect below
@ -884,10 +778,9 @@ begin
Disconnect(False);
end;
procedure TIdHTTPWebsocketClient.SetIOHandlerWS(
const Value: TIdIOHandlerWebsocket);
procedure TIdHTTPWebsocketClient.SetIOHandlerStack(const Value: TIdIOHandlerStack);
begin
SetIOHandler(Value);
inherited IOHandler := Value;
end;
procedure TIdHTTPWebsocketClient.SetOnData(const Value: TWebsocketMsgBin);
@ -923,253 +816,6 @@ begin
Self.IOHandler.Binding.SetSockOpt(SOL_SOCKET, SO_SNDTIMEO, Self.WriteTimeout);
end;
{ TIdHTTPSocketIOClient }
(*
procedure TIdHTTPSocketIOClient_old.AfterConstruction;
begin
inherited;
SocketIOCompatible := True;
FHeartBeat := TTimer.Create(nil);
FHeartBeat.Enabled := False;
FHeartBeat.OnTimer := HeartBeatTimer;
end;
procedure TIdHTTPSocketIOClient_old.AsyncDispatchEvent(const aEvent: string);
begin
//https://github.com/LearnBoost/socket.io-spec
if StartsStr('1:', aEvent) then //connect
Exit;
if aEvent = '2::' then //ping, heartbeat
Exit;
inherited AsyncDispatchEvent(aEvent);
end;
procedure TIdHTTPSocketIOClient_old.AutoConnect;
begin
//for now: timer in mainthread?
TThread.Queue(nil,
procedure
begin
FHeartBeat.Interval := 5 * 1000;
FHeartBeat.Enabled := True;
end);
end;
destructor TIdHTTPSocketIOClient_old.Destroy;
var tmr: TObject;
begin
tmr := FHeartBeat;
TThread.Queue(nil, //otherwise free in other thread than created
procedure
begin
//FHeartBeat.Free;
tmr.Free;
end);
inherited;
end;
procedure TIdHTTPSocketIOClient_old.HeartBeatTimer(Sender: TObject);
begin
FHeartBeat.Enabled := False;
try
try
if (IOHandler <> nil) and
not IOHandler.ClosedGracefully and
IOHandler.Connected then
begin
IOHandler.Write('2:::'); //heartbeat socket.io message
end
//retry connect
else
try
//clear inputbuffer, otherwise it can't connect :(
if (IOHandler <> nil) and
not IOHandler.InputBufferIsEmpty
then
IOHandler.DiscardAll;
Self.Connect;
TryUpgradeToWebsocket;
except
//skip, just retried
end;
except
//clear inputbuffer, otherwise it stays connected :(
if (IOHandler <> nil) and
not IOHandler.InputBufferIsEmpty
then
IOHandler.DiscardAll;
if Assigned(OnDisConnected) then
OnDisConnected(Self);
try
raise EIdException.Create('Connection lost from ' + Format('ws://%s:%d/%s', [Host, Port, WSResourceName]));
except
//eat, no error popup!
end;
end;
finally
FHeartBeat.Enabled := True; //always enable: in case of disconnect it will re-connect
end;
end;
procedure TIdHTTPSocketIOClient_old.InternalUpgradeToWebsocket(
aRaiseException: Boolean; out aFailedReason: string);
var
stimeout: string;
begin
inherited InternalUpgradeToWebsocket(aRaiseException, aFailedReason);
if (aFailedReason = '') and
(IOHandler as TIdIOHandlerWebsocket).IsWebsocket then
begin
stimeout := Copy(SocketIOHandshakeResponse, Pos(':', SocketIOHandshakeResponse)+1, Length(SocketIOHandshakeResponse));
stimeout := Copy(stimeout, 1, Pos(':', stimeout)-1);
if stimeout <> '' then
begin
//if (FHeartBeat.Interval > 0) then
//for now: timer in mainthread?
TThread.Queue(nil,
procedure
begin
FHeartBeat.Interval := StrToIntDef(stimeout, 15) * 1000;
if FHeartBeat.Interval >= 15000 then
//FHeartBeat.Interval := FHeartBeat.Interval - 5000
FHeartBeat.Interval := 5000
else if FHeartBeat.Interval >= 5000 then
FHeartBeat.Interval := FHeartBeat.Interval - 2000;
FHeartBeat.Enabled := (FHeartBeat.Interval > 0);
end);
end;
if Assigned(OnConnected) then
OnConnected(Self);
end;
end;
)
procedure TIdHTTPSocketIOClient_old.ProcessSocketIORequest(
const strmRequest: TStream);
function __ReadToEnd: string;
var
utf8: TBytes;
ilength: Integer;
begin
Result := '';
ilength := strmRequest.Size - strmRequest.Position;
SetLength(utf8, ilength);
strmRequest.Read(utf8[0], ilength);
Result := TEncoding.UTF8.GetString(utf8);
end;
function __GetSocketIOPart(const aData: string; aIndex: Integer): string;
var ipos: Integer;
i: Integer;
begin
//'5::/chat:{"name":"hi!"}'
//0 = 5
//1 =
//2 = /chat
//3 = {"name":"hi!"}
ipos := 0;
for i := 0 to aIndex-1 do
ipos := PosEx(':', aData, ipos+1);
if ipos >= 0 then
begin
Result := Copy(aData, ipos+1, Length(aData));
if aIndex < 3 then // /chat:{"name":"hi!"}'
begin
ipos := PosEx(':', Result, 1); // :{"name":"hi!"}'
if ipos > 0 then
Result := Copy(Result, 1, ipos-1); // /chat
end;
end;
end;
var
str, smsg, schannel, sdata: string;
imsg: Integer;
// bCallback: Boolean;
begin
str := __ReadToEnd;
if str = '' then Exit;
//5:1+:/chat:test
smsg := __GetSocketIOPart(str, 1);
imsg := 0;
// bCallback := False;
if smsg <> '' then // 1+
begin
imsg := StrToIntDef(ReplaceStr(smsg,'+',''), 0); // 1
// bCallback := (Pos('+', smsg) > 1); //trailing +, e.g. 1+
end;
schannel := __GetSocketIOPart(str, 2); // /chat
sdata := __GetSocketIOPart(str, 3); // test
//(0) Disconnect
if StartsStr('0:', str) then
begin
schannel := __GetSocketIOPart(str, 2);
if schannel <> '' then
//todo: close channel
else
Self.Disconnect;
end
//(1) Connect
//'1::' [path] [query]
else if StartsStr('1:', str) then
begin
//todo: add channel/room to authorized channel/room list
Self.IOHandler.Write(str); //write same connect back, e.g. 1::/chat
end
//(2) Heartbeat
else if StartsStr('2:', str) then
begin
Self.IOHandler.Write(str); //write same connect back, e.g. 2::
end
//(3) Message (https://github.com/LearnBoost/socket.io-spec#3-message)
//'3:' [message id ('+')] ':' [message endpoint] ':' [data]
//3::/chat:hi
else if StartsStr('3:', str) then
begin
if Assigned(OnSocketIOMsg) then
OnSocketIOMsg(Self, sdata, imsg);
end
//(4) JSON Message
//'4:' [message id ('+')] ':' [message endpoint] ':' [json]
//4:1::{"a":"b"}
else if StartsStr('4:', str) then
begin
if Assigned(OnSocketIOJson) then
OnSocketIOJson(Self, sdata, imsg);
end
//(5) Event
//'5:' [message id ('+')] ':' [message endpoint] ':' [json encoded event]
//5::/chat:{"name":"my other event","args":[{"my":"data"}]}
//5:1+:/chat:{"name":"GetLocations","args":[""]}
else if StartsStr('5:', str) then
begin
if Assigned(OnSocketIOEvent) then
OnSocketIOEvent(Self, sdata, imsg);
end
//(6) ACK
//6::/news:1+["callback"]
//6:::1+["Response"]
//(7) Error
//(8) Noop
else if StartsStr('8:', str) then
begin
//nothing
end
else
raise Exception.CreateFmt('Unsupported data: "%s"', [str]);
end;
*)
{ TIdWebsocketMultiReadThread }
procedure TIdWebsocketMultiReadThread.AddClient(
@ -1309,7 +955,7 @@ procedure TIdWebsocketMultiReadThread.PingAllChannels;
var
l: TList;
chn: TIdHTTPWebsocketClient;
ws: TIdIOHandlerWebsocket;
ws: TWebsocketImplementationProxy;
i: Integer;
begin
if Terminated then Exit;
@ -1321,10 +967,10 @@ begin
chn := TIdHTTPWebsocketClient(l.Items[i]);
if chn.NoAsyncRead then Continue;
ws := chn.IOHandler as TIdIOHandlerWebsocket;
ws := chn.IOHandlerWS;
//valid?
if (chn.IOHandler <> nil) and
(chn.IOHandler.IsWebsocket) and
(chn.IOHandlerWS.IsWebsocket) and
(chn.Socket <> nil) and
(chn.Socket.Binding <> nil) and
(chn.Socket.Binding.Handle > 0) and
@ -1391,7 +1037,7 @@ begin
end;
//try reconnect
ws := chn.IOHandler as TIdIOHandlerWebsocket;
ws := chn.IOHandlerWS;
if ( (ws = nil) or
(SecondsBetween(Now, ws.LastActivityTime) >= 5) ) then
begin
@ -1433,7 +1079,7 @@ var
iCount,
i: Integer;
iResult: NativeInt;
ws: TIdIOHandlerWebsocket;
ws: TWebsocketImplementationProxy;
begin
l := FChannels.LockList;
try
@ -1449,13 +1095,13 @@ begin
//valid?
if //not chn.Busy and also take busy channels (will be ignored later), otherwise we have to break/reset for each RO function execution
(chn.IOHandler <> nil) and
(chn.IOHandler.IsWebsocket) and
(chn.IOHandlerWS.IsWebsocket) and
(chn.Socket <> nil) and
(chn.Socket.Binding <> nil) and
(chn.Socket.Binding.Handle > 0) and
(chn.Socket.Binding.Handle <> INVALID_SOCKET) then
begin
if chn.IOHandler.HasData then
if chn.IOHandlerWS.HasData then
begin
Inc(iResult);
Break;
@ -1513,13 +1159,12 @@ begin
//check for data for all channels
for i := 0 to l.Count - 1 do
begin
if l = nil then Exit;
chn := TIdHTTPWebsocketClient(l.Items[i]);
if chn.NoAsyncRead then Continue;
if chn.TryLock then
try
ws := chn.IOHandler as TIdIOHandlerWebsocket;
ws := chn.IOHandlerWS;
if (ws = nil) then Continue;
if ws.TryLock then //IOHandler.Readable cannot be done during pending action!

637
IdIOHandlerWebsocket.pas
View file

File diff suppressed because it is too large Load diff

144
IdServerIOHandlerWebsocket.pas
View file

@ -1,36 +1,26 @@
unit IdServerIOHandlerWebsocket;
interface
{$I wsdefines.pas}
uses
Classes
, IdServerIOHandlerStack
, IdIOHandlerStack
, IdGlobal
, IdIOHandler
, IdYarn
, IdThread
, IdSocketHandle
//
, IdIOHandlerWebsocket
{$IFDEF WEBSOCKETSSL}
, IdSSLOpenSSL
{$ENDIF}
;
Classes,
IdServerIOHandlerStack, IdIOHandlerStack, IdGlobal, IdIOHandler, IdYarn, IdThread, IdSocketHandle,
IdIOHandlerWebsocket, IdSSLOpenSSL, sysutils;
type
{$IFDEF WEBSOCKETSSL}
TIdServerIOHandlerWebsocket = class(TIdServerIOHandlerSSLOpenSSL)
{$ELSE}
TIdServerIOHandlerWebsocket = class(TIdServerIOHandlerStack)
{$ENDIF}
protected
procedure InitComponent; override;
{$IFDEF WEBSOCKETSSL}
function CreateOpenSSLSocket:TIdSSLIOHandlerSocketOpenSSL; override;
{$ENDIF}
public
function Accept(ASocket: TIdSocketHandle; AListenerThread: TIdThread;
AYarn: TIdYarn): TIdIOHandler; override;
function Accept(ASocket: TIdSocketHandle; AListenerThread: TIdThread; AYarn: TIdYarn): TIdIOHandler; override;
function MakeClientIOHandler(ATheThread:TIdYarn): TIdIOHandler; override;
end;
TIdServerIOHandlerWebsocketSSL = class(TIdServerIOHandlersslOpenSSL)
protected
procedure InitComponent; override;
public
function Accept(ASocket: TIdSocketHandle; AListenerThread: TIdThread; AYarn: TIdYarn): TIdIOHandler; override;
function MakeClientIOHandler(ATheThread:TIdYarn): TIdIOHandler; override;
end;
@ -38,43 +28,115 @@ implementation
{ TIdServerIOHandlerStack_Websocket }
{$IFDEF WEBSOCKETSSL}
function TIdServerIOHandlerWebsocket.CreateOpenSSLSocket:TIdSSLIOHandlerSocketOpenSSL;
begin
Result := TIdIOHandlerWebsocket.Create(nil);
end;
{$ENDIF}
function TIdServerIOHandlerWebsocket.Accept(ASocket: TIdSocketHandle;
AListenerThread: TIdThread; AYarn: TIdYarn): TIdIOHandler;
var
LIOHandler: TIdIOHandlerWebsocketPlain;
begin
Result := inherited Accept(ASocket, AListenerThread, AYarn);
//Result := inherited Accept(ASocket, AListenerThread, AYarn);
//using a custom scheduler, AYarn may be nil, so don't assert
Assert(ASocket<>nil);
Assert(AListenerThread<>nil);
Result := nil;
LIOHandler := TIdIOHandlerWebsocketPlain.Create(nil);
try
LIOHandler.Open;
while not AListenerThread.Stopped do
begin
if ASocket.Select(250) then
begin
if LIOHandler.Binding.Accept(ASocket.Handle) then
begin
LIOHandler.AfterAccept;
Result := LIOHandler;
LIOHandler := nil;
Break;
end;
end;
end;
finally
FreeAndNil(LIOHandler);
end;
if Result <> nil then
begin
(Result as TIdIOHandlerWebsocket).IsServerSide := True; //server must not mask, only client
(Result as TIdIOHandlerWebsocket).UseNagle := False;
(Result as TIdIOHandlerWebsocketPlain).WebsocketImpl.IsServerSide := True; //server must not mask, only client
(Result as TIdIOHandlerWebsocketPlain).UseNagle := False;
end;
end;
procedure TIdServerIOHandlerWebsocket.InitComponent;
begin
inherited InitComponent;
{$IFNDEF WEBSOCKETSSL}
IOHandlerSocketClass := TIdIOHandlerWebsocket;
{$ENDIF}
//IOHandlerSocketClass := TIdIOHandlerWebsocket;
end;
function TIdServerIOHandlerWebsocket.MakeClientIOHandler(
ATheThread: TIdYarn): TIdIOHandler;
begin
Result := inherited MakeClientIOHandler(ATheThread);
{$IFNDEF WEBSOCKETSSL}
if Result <> nil then
begin
(Result as TIdIOHandlerWebsocket).IsServerSide := True; //server must not mask, only client
(Result as TIdIOHandlerWebsocket).UseNagle := False;
(Result as TIdIOHandlerWebsocketPlain).WebsocketImpl.IsServerSide := True; //server must not mask, only client
(Result as TIdIOHandlerWebsocketPlain).UseNagle := False;
end;
end;
{ TIdServerIOHandlerWebsocketSSL }
function TIdServerIOHandlerWebsocketSSL.Accept(ASocket: TIdSocketHandle; AListenerThread: TIdThread;
AYarn: TIdYarn): TIdIOHandler;
var
LIO: TIdIOHandlerWebsocketSSL;
begin
Assert(ASocket<>nil);
Assert(fSSLContext<>nil);
LIO := TIdIOHandlerWebsocketSSL.Create(nil);
try
LIO.PassThrough := True; //initial no ssl?
//we need to pass the SSLOptions for the socket from the server
LIO.SSLOptions := SSLOptions;
LIO.IsPeer := True; //shared SSLOptions + fSSLContext
LIO.Open;
if LIO.Binding.Accept(ASocket.Handle) then
begin
//LIO.ClearSSLOptions;
LIO.SSLSocket := TIdSSLSocket.Create(Self);
LIO.SSLContext := fSSLContext;
end
else
begin
FreeAndNil(LIO);
end;
except
LIO.Free;
raise;
end;
Result := LIO;
if Result <> nil then
begin
(Result as TIdIOHandlerWebsocketSSL).WebsocketImpl.IsServerSide := True; //server must not mask, only client
(Result as TIdIOHandlerWebsocketSSL).UseNagle := False;
end;
end;
procedure TIdServerIOHandlerWebsocketSSL.InitComponent;
begin
inherited InitComponent;
//IOHandlerSocketClass := TIdIOHandlerWebsocket;
end;
function TIdServerIOHandlerWebsocketSSL.MakeClientIOHandler(ATheThread: TIdYarn): TIdIOHandler;
begin
Result := inherited MakeClientIOHandler(ATheThread);
if Result <> nil then
begin
(Result as TIdIOHandlerWebsocketSSL).WebsocketImpl.IsServerSide := True; //server must not mask, only client
(Result as TIdIOHandlerWebsocketSSL).UseNagle := False;
end;
{$ENDIF}
end;
end.

62
IdServerSocketIOHandling.pas
View file

@ -1,18 +1,12 @@
unit IdServerSocketIOHandling;
interface
{$I wsdefines.pas}
uses
Classes, Generics.Collections, SysUtils, StrUtils
, IdContext
, IdCustomTCPServer
, IdException
//
{$IFDEF SUPEROBJECT}
, superobject
{$ENDIF}
, IdServerBaseHandling
, IdSocketIOHandling
;
IdContext, IdCustomTCPServer,
//IdServerWebsocketContext,
Classes, Generics.Collections,
superobject, IdException, IdServerBaseHandling, IdSocketIOHandling;
type
TIdServerSocketIOHandling = class(TIdBaseSocketIOHandling)
@ -21,27 +15,22 @@ type
public
function SendToAll(const aMessage: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil): Integer;
procedure SendTo (const aContext: TIdServerContext; const aMessage: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);
function EmitEventToAll(const aEventName: string; const aData: string ; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil): Integer;overload;
{$IFDEF SUPEROBJECT}
function EmitEventToAll(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil): Integer;overload;
procedure EmitEventTo (const aContext: TIdServerContext;
const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
function EmitEventToAll(const aEventName: string; const aData: string ; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil): Integer;overload;
procedure EmitEventTo (const aContext: ISocketIOContext;
const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
{$ENDIF}
procedure EmitEventTo (const aContext: TIdServerContext;
const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
end;
implementation
uses
SysUtils, StrUtils;
{ TIdServerSocketIOHandling }
procedure TIdServerSocketIOHandling.ProcessHeatbeatRequest(
const AContext: ISocketIOContext; const aText: string);
begin
inherited ProcessHeatbeatRequest(AContext, aText);
end;
{$IFDEF SUPEROBJECT}
procedure TIdServerSocketIOHandling.EmitEventTo(
const aContext: ISocketIOContext; const aEventName: string;
const aData: ISuperObject; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
@ -83,16 +72,6 @@ begin
end;
end;
function TIdServerSocketIOHandling.EmitEventToAll(const aEventName: string; const aData: ISuperObject;
const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError): Integer;
begin
if aData.IsType(stString) then
Result := EmitEventToAll(aEventName, '"' + aData.AsString + '"', aCallback, aOnError)
else
Result := EmitEventToAll(aEventName, aData.AsString, aCallback, aOnError);
end;
{$ENDIF}
function TIdServerSocketIOHandling.EmitEventToAll(const aEventName,
aData: string; const aCallback: TSocketIOMsgJSON;
const aOnError: TSocketIOError): Integer;
@ -146,6 +125,21 @@ begin
end;
end;
function TIdServerSocketIOHandling.EmitEventToAll(const aEventName: string; const aData: ISuperObject;
const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError): Integer;
begin
if aData.IsType(stString) then
Result := EmitEventToAll(aEventName, '"' + aData.AsString + '"', aCallback, aOnError)
else
Result := EmitEventToAll(aEventName, aData.AsString, aCallback, aOnError);
end;
procedure TIdServerSocketIOHandling.ProcessHeatbeatRequest(
const AContext: ISocketIOContext; const aText: string);
begin
inherited ProcessHeatbeatRequest(AContext, aText);
end;
procedure TIdServerSocketIOHandling.SendTo(const aContext: TIdServerContext;
const aMessage: string; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
var

35
IdServerWebsocketContext.pas
View file

@ -1,22 +1,16 @@
unit IdServerWebsocketContext;
interface
{$I wsdefines.pas}
uses
Classes, strUtils
, IdContext
, IdCustomTCPServer
, IdCustomHTTPServer
//
, IdIOHandlerWebsocket
, IdServerBaseHandling
, IdServerSocketIOHandling
;
Classes,
IdCustomTCPServer, IdIOHandlerWebsocket,
IdServerBaseHandling, IdServerSocketIOHandling, IdContext, IdIOHandlerStack;
type
TIdServerWSContext = class;
TWebSocketUpgradeEvent = procedure(const AContext: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo; var Accept:boolean) of object;
TWebsocketChannelRequest = procedure(const AContext: TIdServerWSContext; var aType:TWSDataType; const strmRequest, strmResponse: TMemoryStream) of object;
TWebsocketChannelRequest = procedure(const AContext: TIdServerWSContext; aType: TWSDataType; const strmRequest, strmResponse: TMemoryStream) of object;
TIdServerWSContext = class(TIdServerContext)
private
@ -31,12 +25,12 @@ type
FWebSocketExtensions: string;
FCookie: string;
//FSocketIOPingSend: Boolean;
fOnWebSocketUpgrade: TWebSocketUpgradeEvent;
FOnCustomChannelExecute: TWebsocketChannelRequest;
FSocketIO: TIdServerSocketIOHandling;
FOnDestroy: TIdContextEvent;
public
function IOHandler: TIdIOHandlerWebsocket;
function IOHandler: TIdIOHandlerStack;
function WebsocketImpl: TWebsocketImplementationProxy;
public
function IsSocketIO: Boolean;
property SocketIO: TIdServerSocketIOHandling read FSocketIO write FSocketIO;
@ -57,12 +51,14 @@ type
property WebSocketVersion : Integer read FWebSocketVersion write FWebSocketVersion;
property WebSocketExtensions: string read FWebSocketExtensions write FWebSocketExtensions;
public
property OnWebSocketUpgrade: TWebsocketUpgradeEvent read FOnWebSocketUpgrade write FOnWebSocketUpgrade;
property OnCustomChannelExecute: TWebsocketChannelRequest read FOnCustomChannelExecute write FOnCustomChannelExecute;
end;
implementation
uses
StrUtils;
{ TIdServerWSContext }
destructor TIdServerWSContext.Destroy;
@ -72,9 +68,9 @@ begin
inherited;
end;
function TIdServerWSContext.IOHandler: TIdIOHandlerWebsocket;
function TIdServerWSContext.IOHandler: TIdIOHandlerStack;
begin
Result := Self.Connection.IOHandler as TIdIOHandlerWebsocket;
Result := Self.Connection.IOHandler as TIdIOHandlerStack;
end;
function TIdServerWSContext.IsSocketIO: Boolean;
@ -83,4 +79,9 @@ begin
Result := StartsText('/socket.io/1/websocket/', FPath);
end;
function TIdServerWSContext.WebsocketImpl: TWebsocketImplementationProxy;
begin
Result := (IOHandler as IWebsocketFunctions).WebsocketImpl;
end;
end.

90
IdServerWebsocketHandling.pas
View file

@ -1,33 +1,27 @@
unit IdServerWebsocketHandling;
interface
{$I wsdefines.pas}
uses
Classes, StrUtils, SysUtils, DateUtils
, IdCoderMIME
, IdThread
, IdContext
, IdCustomHTTPServer
IdContext, IdCustomHTTPServer,
{$IF CompilerVersion <= 21.0} //D2010
, IdHashSHA1
IdHashSHA1,
{$else}
, IdHashSHA //XE3 etc
IdHashSHA, //XE3 etc
{$IFEND}
, IdServerSocketIOHandling
//
, IdSocketIOHandling
, IdServerBaseHandling
, IdServerWebsocketContext
, IdIOHandlerWebsocket
;
IdServerSocketIOHandling, IdServerWebsocketContext,
Classes, IdServerBaseHandling, IdIOHandlerWebsocket, IdSocketIOHandling;
type
TIdServerSocketIOHandling_Ext = class(TIdServerSocketIOHandling)
end;
TIdCustomHTTPServer_Ext = class(TIdCustomHTTPServer);
TIdServerWebsocketHandling = class(TIdServerBaseHandling)
protected
class procedure DoWSExecute(AThread: TIdContext; aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual;
class procedure HandleWSMessage(AContext: TIdServerWSContext; var aType: TWSDataType;
class procedure HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType;
aRequestStrm, aResponseStrm: TMemoryStream;
aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual;
public
@ -39,6 +33,10 @@ type
implementation
uses
StrUtils, SysUtils, DateUtils,
IdCustomTCPServer, IdCoderMIME, IdThread;
{ TIdServerWebsocketHandling }
class function TIdServerWebsocketHandling.CurrentSocket: ISocketIOContext;
@ -65,10 +63,10 @@ begin
try
context := AThread as TIdServerWSContext;
//todo: make seperate function + do it after first real write (not header!)
if context.IOHandler.BusyUpgrading then
if context.WebsocketImpl.BusyUpgrading then
begin
context.IOHandler.IsWebsocket := True;
context.IOHandler.BusyUpgrading := False;
context.WebsocketImpl.IsWebsocket := True;
context.WebsocketImpl.BusyUpgrading := False;
end;
//initial connect
if context.IsSocketIO then
@ -83,10 +81,13 @@ begin
while AThread.Connection.Connected do
begin
if context.IOHandler.HasData or
if context.WebsocketImpl.HasData or
(AThread.Connection.IOHandler.InputBuffer.Size > 0) or
AThread.Connection.IOHandler.Readable(1 * 1000) then //wait 5s, else ping the client(!)
begin
if not (context.WebsocketImpl.HasData or (context.IOHandler.InputBuffer.Size > 0)) then
Continue;
tstart := Now;
strmResponse := TMemoryStream.Create;
@ -103,24 +104,32 @@ begin
if wscode in [wdcPing, wdcPong] then
begin
if wscode = wdcPing then
context.IOHandler.WriteData(nil, wdcPong);
context.WebsocketImpl.WriteData(nil, wdcPong);
Continue;
end;
if wscode = wdcText
then wstype := wdtText
else wstype := wdtBinary;
if wscode = wdcText then
wstype := wdtText
else
wstype := wdtBinary;
try
HandleWSMessage(context, wstype, strmRequest, strmResponse, aSocketIOHandler);
except
on E:Exception do
TIdCustomHTTPServer_Ext(context.Server as TIdCustomHTTPServer).DoCommandError(context, nil, nil, E);
end;
//write result back (of the same type: text or bin)
if strmResponse.Size > 0 then
begin
if wstype = wdtText
then context.IOHandler.Write(strmResponse, wdtText)
else context.IOHandler.Write(strmResponse, wdtBinary)
if wscode = wdcText then
context.WebsocketImpl.Write(strmResponse, wdtText)
else
context.WebsocketImpl.Write(strmResponse, wdtBinary)
end
else context.IOHandler.WriteData(nil, wdcPing);
else
context.WebsocketImpl.WriteData(nil, wdcPing);
finally
strmRequest.Free;
strmResponse.Free;
@ -138,7 +147,7 @@ begin
aSocketIOHandler.WritePing(context);
end
else
context.IOHandler.WriteData(nil, wdcPing);
context.WebsocketImpl.WriteData(nil, wdcPing);
end;
end;
@ -148,12 +157,14 @@ begin
Assert(aSocketIOHandler <> nil);
aSocketIOHandler.WriteDisConnect(context);
end;
context.IOHandler.Clear;
context.WebsocketImpl.Clear;
AThread.Data := nil;
end;
end;
class procedure TIdServerWebsocketHandling.HandleWSMessage(AContext: TIdServerWSContext; var aType:TWSDataType; aRequestStrm, aResponseStrm: TMemoryStream; aSocketIOHandler: TIdServerSocketIOHandling_Ext);
class procedure TIdServerWebsocketHandling.HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType;
aRequestStrm, aResponseStrm: TMemoryStream;
aSocketIOHandler: TIdServerSocketIOHandling_Ext);
begin
if AContext.IsSocketIO then
begin
@ -169,7 +180,6 @@ class function TIdServerWebsocketHandling.ProcessServerCommandGet(
AThread: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo): Boolean;
var
Accept: Boolean;
sValue, squid: string;
context: TIdServerWSContext;
hash: TIdHashSHA1;
@ -194,7 +204,8 @@ begin
Sec-WebSocket-Version: 13 *)
//Connection: Upgrade
if not ContainsText(ARequestInfo.Connection, 'Upgrade') then //Firefox uses "keep-alive, Upgrade"
if not ( ContainsText(ARequestInfo.Connection, 'Upgrade') or //Firefox uses "keep-alive, Upgrade"
ContainsText(ARequestInfo.RawHeaders.Values['upgrade'], 'websocket') ) then //"connection" is empty in case of SSL? so check header too
begin
//initiele ondersteuning voor socket.io
if SameText(ARequestInfo.document , '/socket.io/1/') then
@ -244,13 +255,6 @@ begin
Result := True; //handled
context := AThread as TIdServerWSContext;
if Assigned(Context.OnWebSocketUpgrade) then
begin
Accept := True;
Context.OnWebSocketUpgrade(Context,ARequestInfo,Accept);
if not Accept then Abort;
end;
//Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==
sValue := ARequestInfo.RawHeaders.Values['sec-websocket-key'];
//"The value of this header field MUST be a nonce consisting of a randomly
@ -332,17 +336,21 @@ begin
hash.Free;
end;
AResponseInfo.CustomHeaders.Values['Sec-WebSocket-Accept'] := sValue;
AResponseInfo.CustomHeaders.Values['Keep-alive'] := 'true';
//send same protocol back?
AResponseInfo.CustomHeaders.Values['Sec-WebSocket-Protocol'] := context.WebSocketProtocol;
//we do not support extensions yet (gzip deflate compression etc)
//AResponseInfo.CustomHeaders.Values['Sec-WebSocket-Extensions'] := context.WebSocketExtensions;
//http://www.lenholgate.com/blog/2011/07/websockets---the-deflate-stream-extension-is-broken-and-badly-designed.html
//but is could be done using idZlib.pas and DecompressGZipStream etc
AResponseInfo.CustomHeaders.Values['sec-websocket-extensions'] := '';
context.WebSocketExtensions := '';
//send response back
context.IOHandler.InputBuffer.Clear;
context.IOHandler.BusyUpgrading := True;
context.WebsocketImpl.BusyUpgrading := True;
AResponseInfo.WriteHeader;
//handle all WS communication in seperate loop

269
IdSocketIOHandling.pas
View file

@ -1,24 +1,14 @@
unit IdSocketIOHandling;
interface
{$I wsdefines.pas}
uses
windows, SyncObjs, SysUtils, StrUtils, Classes, Generics.Collections
{$IFDEF SUPEROBJECT}
, superobject
{$ENDIF}
, IdContext
, IdException
, IdHTTP
//
, IdServerBaseHandling
, IdIOHandlerWebsocket
;
Classes, Generics.Collections,
superobject,
IdServerBaseHandling, IdContext, IdException, IdIOHandlerWebsocket, IdHTTP,
SyncObjs, SysUtils, IdIOHandlerStack;
type
{$IFNDEF SUPEROBJECT}
TSuperArray = String;
{$ENDIF}
TSocketIOContext = class;
TSocketIOCallbackObj = class;
TIdBaseSocketIOHandling = class;
@ -28,13 +18,9 @@ type
ISocketIOCallback = interface;
TSocketIOMsg = reference to procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: ISocketIOCallback);
{$IFDEF SUPEROBJECT}
TSocketIOMsgJSON = reference to procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: ISocketIOCallback);
{$ELSE}
TSocketIOMsgJSON = reference to procedure(const ASocket: ISocketIOContext; const aJSON:string; const aCallback: ISocketIOCallback);
{$ENDIF}
TSocketIOEvent = reference to procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallback: ISocketIOCallback);
TSocketIONotify = reference to procedure(const ASocket: ISocketIOContext);
TSocketIOEvent = reference to procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallback: ISocketIOCallback);
TSocketIOError = reference to procedure(const ASocket: ISocketIOContext; const aErrorClass, aErrorMessage: string);
TSocketIOEventError = reference to procedure(const ASocket: ISocketIOContext; const aCallback: ISocketIOCallback; E: Exception);
@ -62,15 +48,14 @@ type
function IsDisconnected: Boolean;
{$IFDEF SUPEROBJECT}
procedure EmitEvent(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
procedure SendJSON(const aJSON: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);
{$ENDIF}
procedure EmitEvent(const aEventName: string; const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
procedure Send(const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);
procedure SendJSON(const aJSON: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);
end;
TSocketIOContext = class(TInterfacedObject,ISocketIOContext)
TSocketIOContext = class(TInterfacedObject,
ISocketIOContext)
private
FLock: TCriticalSection;
FPingSend: Boolean;
@ -89,7 +74,7 @@ type
protected
FHandling: TIdBaseSocketIOHandling;
FContext: TIdContext;
FIOHandler: TIdIOHandlerWebsocket;
FIOHandler: TIdIOHandlerStack;
FClient: TIdHTTP;
FEvent: TEvent;
FQueue: TList<string>;
@ -119,15 +104,14 @@ type
property CustomData: TObject read GetCustomData write SetCustomData;
property OwnsCustomData: Boolean read GetOwnsCustomData write SetOwnsCustomData;
procedure EmitEvent(const aEventName: string; const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
procedure Send(const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);
{$IFDEF SUPEROBJECT}
//todo: OnEvent per socket
//todo: store session info per connection (see Socket.IO Set + Get -> Storing data associated to a client)
//todo: namespace using "Of"
procedure EmitEvent(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
procedure EmitEvent(const aEventName: string; const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
// procedure BroadcastEventToOthers(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil);
procedure Send(const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);
procedure SendJSON(const aJSON: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);
{$ENDIF}
end;
ISocketIOCallback = interface
@ -153,9 +137,7 @@ type
protected
Done, Success: Boolean;
Error: Exception;
{$IFDEF SUPEROBJECT}
Data : ISuperObject;
{$ENDIF}
Event: TEvent;
public
procedure AfterConstruction; override;
@ -176,13 +158,12 @@ type
FOnDisconnectList: TSocketIONotifyList;
FOnEventList: TObjectDictionary<string,TSocketIOEventList>;
FOnSocketIOMsg: TSocketIOMsg;
{$IFDEF SUPEROBJECT}
FOnSocketIOJson: TSocketIOMsgJSON;
{$ENDIF}
procedure ProcessEvent(const AContext: ISocketIOContext; const aText: string; aMsgNr: Integer; aHasCallback: Boolean);
private
FOnEventError: TSocketIOEventError;
FDefaultErrorCallback: TSocketIOError;
protected
type
TSocketIOCallback = procedure(const aData: string) of object;
@ -206,9 +187,7 @@ type
procedure WriteSocketIOJSON(const ASocket: ISocketIOContext; const aRoom, aJSON: string; aCallback: TSocketIOCallbackRef = nil; const aOnError: TSocketIOError = nil);
procedure WriteSocketIOEvent(const ASocket: ISocketIOContext; const aRoom, aEventName, aJSONArray: string; aCallback: TSocketIOCallback; const aOnError: TSocketIOError);
procedure WriteSocketIOEventRef(const ASocket: ISocketIOContext; const aRoom, aEventName, aJSONArray: string; aCallback: TSocketIOCallbackRef; const aOnError: TSocketIOError);
{$IFDEF SUPEROBJECT}
function WriteSocketIOEventSync(const ASocket: ISocketIOContext; const aRoom, aEventName, aJSONArray: string; aMaxwait_ms: Cardinal = INFINITE): ISuperObject;
{$ENDIF}
procedure WriteSocketIOResult(const ASocket: ISocketIOContext; aRequestMsgNr: Integer; const aRoom, aData: string);
procedure ProcessSocketIO_XHR(const aGUID: string; const aStrmRequest, aStrmResponse: TStream);
@ -237,14 +216,13 @@ type
procedure FreeConnection(const ASocket: ISocketIOContext);overload;
property OnSocketIOMsg : TSocketIOMsg read FOnSocketIOMsg write FOnSocketIOMsg;
{$IFDEF SUPEROBJECT}
property OnSocketIOJson : TSocketIOMsgJSON read FOnSocketIOJson write FOnSocketIOJson;
{$ENDIF}
procedure OnEvent (const aEventName: string; const aCallback: TSocketIOEvent);
procedure OnConnection(const aCallback: TSocketIONotify);
procedure OnDisconnect(const aCallback: TSocketIONotify);
property OnEventError: TSocketIOEventError read FOnEventError write FOnEventError;
property DefaultErrorCallback: TSocketIOError read FDefaultErrorCallback write FDefaultErrorCallback;
procedure EnumerateSockets(const aEachSocketCallback: TSocketIONotify);
end;
@ -252,29 +230,15 @@ type
TIdSocketIOHandling = class(TIdBaseSocketIOHandling)
public
procedure Send(const aMessage: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);
procedure Emit(const aEventName: string; const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
{$IFDEF SUPEROBJECT}
procedure Emit(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
function EmitSync(const aEventName: string; const aData: ISuperObject; aMaxwait_ms: Cardinal = INFINITE): ISuperobject;
//procedure Emit(const aEventName: string; const aData: string; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload;
{$ENDIF}
end;
{$IFNDEF SUPEROBJECT}
function SO(const S:string):string; inline;
{$ENDIF}
implementation
uses
IdServerWebsocketContext, IdHTTPWebsocketClient;
{$IFNDEF SUPEROBJECT}
function SO(const S:string):string; inline;
begin
Result := S;
end;
{$ENDIF}
StrUtils, IdServerWebsocketContext, IdHTTPWebsocketClient, Windows;
procedure TIdBaseSocketIOHandling.AfterConstruction;
begin
@ -540,7 +504,8 @@ begin
FOnDisconnectList.Add(aCallback);
end;
procedure TIdBaseSocketIOHandling.OnEvent(const aEventName: string; const aCallback: TSocketIOEvent);
procedure TIdBaseSocketIOHandling.OnEvent(const aEventName: string;
const aCallback: TSocketIOEvent);
var list: TSocketIOEventList;
begin
if not FOnEventList.TryGetValue(aEventName, list) then
@ -560,91 +525,31 @@ begin
TSocketIOContext(ASocket).FContext.Connection.Disconnect;
end;
procedure TIdBaseSocketIOHandling.ProcessEvent(const AContext: ISocketIOContext; const aText: string; aMsgNr: Integer;aHasCallback: Boolean);
procedure TIdBaseSocketIOHandling.ProcessEvent(
const AContext: ISocketIOContext; const aText: string; aMsgNr: Integer;
aHasCallback: Boolean);
var
name: string;
{$IFNDEF SUPEROBJECT}
args: string;
{$ELSE}
args: TSuperArray;
json: ISuperObject;
// socket: TSocketIOContext;
{$ENDIF}
name: string;
args: TSuperArray;
list: TSocketIOEventList;
event: TSocketIOEvent;
callback: ISocketIOCallback;
{$IFNDEF SUPEROBJECT}
function _GetJsonMember(const aText:string; const iName:string):string;
var xs,xe,ctn:Integer;
begin
// Based on json formated content
Result := '';
xs := Pos('"'+iName+'"',aText);
if xs=0 then Exit;
xs := PosEx(':',aText,xs);
if xs=0 then Exit;
//
inc(xs);
while (xs<=length(aText)) and (aText[xs] in [' ',#13,#10,#8,#9]) do inc(xs);
if xs>=length(aText) then Exit;
//
if aText[xs]='[' then
begin
xe := xs+1; ctn := 1;
while (xe<=length(aText)) do
begin
if aText[xe]='[' then inc(ctn);
if aText[xe]=']' then dec(ctn);
if ctn=0 then break;
inc(xe);
end;
if ctn=0 then
Result := Copy(aText,xs,xe-xs+1);
end
else
if aText[xs]='{' then
begin
xe := xs+1; ctn := 1;
while (xe<=length(aText)) do
begin
if aText[xe]='{' then inc(ctn);
if aText[xe]='}' then dec(ctn);
if ctn=0 then break;
inc(xe);
end;
if ctn=0 then
Result := Copy(aText,xs,xe-xs+1);
end
else
if aText[xs]='"' then
begin
xe := PosEx('"',aText,xs+1);
if xe=0 then Exit;
Result := Copy(aText,xs+1,xe-xs-1);
end;
end;
{$ENDIF}
// socket: TSocketIOContext;
begin
//'5:' [message id ('+')] ':' [message endpoint] ':' [json encoded event]
//5::/chat:{"name":"my other event","args":[{"my":"data"}]}
//5:1+:/chat:{"name":"GetLocations","args":[""]}
{$IFNDEF SUPEROBJECT}
name := _GetJsonMember(aText,'name'); //"my other event
args := _GetJsonMember(aText,'args'); //[{"my":"data"}]
{$ELSE}
json := SO(aText);
// args := nil;
try
name := json.S['name']; //"my other event
args := json.A['args']; //[{"my":"data"}]
{$ENDIF}
if FOnEventList.TryGetValue(name, list) then
begin
if list.Count = 0 then
raise EIdSocketIoUnhandledMessage.Create(aText);
raise EIdSocketIoUnhandledMessage.Create('No listener available for event: ' + aText);
// socket := FConnections.Items[AContext];
if aHasCallback then
@ -657,28 +562,21 @@ begin
event(AContext, args, callback);
except on E:Exception do
if Assigned(OnEventError) then
OnEventError(AContext, callback, e)
OnEventError(AContext, callback, e) //custom error handling (send different error back to remote client/context/initiator?)
else
if callback <> nil then
{$IFNDEF SUPEROBJECT}
callback.SendResponse('Error');
{$ELSE}
callback.SendResponse( SO(['Error', SO(['msg', e.message])]).AsJSon );
{$ENDIF}
end;
finally
callback := nil;
end;
end
else
raise EIdSocketIoUnhandledMessage.Create(aText);
{$IFDEF SUPEROBJECT}
raise EIdSocketIoUnhandledMessage.Create('No listeners registered for event: ' + aText);
finally
// args.Free;
json := nil;
end;
{$ENDIF}
end;
procedure TIdBaseSocketIOHandling.ProcessHeatbeatRequest(const ASocket: ISocketIOContext; const aText: string);
@ -846,6 +744,7 @@ procedure TIdBaseSocketIOHandling.ProcessSocketIORequest(
var
str, smsg, schannel, sdata: string;
sErrorType, sErrorMsg: string;
imsg: Integer;
bCallback: Boolean;
// socket: TSocketIOContext;
@ -853,9 +752,7 @@ var
callbackref: TSocketIOCallbackRef;
callbackobj: ISocketIOCallback;
errorref: TSocketIOError;
{$IFDEF SUPEROBJECT}
error: ISuperObject;
{$ENDIF}
socket: TSocketIOContext;
begin
if ASocket = nil then Exit;
@ -928,12 +825,8 @@ begin
except
on E:Exception do
begin
{$IFDEF SUPEROBJECT}
if not callbackobj.IsResponseSend then
callbackobj.SendResponse( SO(['Error', SO(['Type', e.ClassName, 'Message', e.Message])]).AsJSon );
{$ELSE}
//TODO
{$ENDIF}
end;
end;
finally
@ -951,7 +844,6 @@ begin
//4:1::{"a":"b"}
else if StartsStr('4:', str) then
begin
{$IFDEF SUPEROBJECT}
if Assigned(OnSocketIOJson) then
begin
if bCallback then
@ -975,7 +867,6 @@ begin
OnSocketIOJson(ASocket, SO(sdata), nil); //, imsg, bCallback);
end
else
{$ENDIF}
raise EIdSocketIoUnhandledMessage.Create(str);
end
//(5) Event
@ -990,7 +881,7 @@ begin
ProcessEvent(socket, sdata, imsg, bCallback);
except
on e:exception do
//
raise
end
end
//(6) ACK
@ -1002,28 +893,47 @@ begin
imsg := StrToIntDef(smsg, 0);
sData := Copy(sdata, Pos('+', sData)+1, Length(sData));
TSocketIOContext(ASocket).FPendingMessages.Remove(imsg);
if FSocketIOErrorRef.TryGetValue(imsg, errorref) then
begin
FSocketIOErrorRef.Remove(imsg);
error := nil;
//'[{"Error":{"Message":"Operation aborted","Type":"EAbort"}}]'
{$IFDEF SUPEROBJECT}
if ContainsText(sdata, '{"Error":') then
begin
error := SO(sdata);
if error.IsType(stArray) then
error := error.O['0'];
error := error.O['Error'];
sErrorType := error.S['Type'];
if error.S['Message'] <> '' then
errorref(ASocket, error.S['Type'], error.S['Message'])
sErrorMsg := error.S['Message']
else if error.S['msg'] <> '' then
sErrorMsg := error.S['msg']
else
errorref(ASocket, 'Unknown', sdata);
begin
sErrorMsg := sdata;
sErrorType := 'Unknown';
end;
end;
TSocketIOContext(ASocket).FPendingMessages.Remove(imsg);
if FSocketIOErrorRef.TryGetValue(imsg, errorref) then
begin
FSocketIOErrorRef.Remove(imsg);
if error <> nil then
begin
errorref(ASocket, sErrorType, sErrorMsg);
FSocketIOEventCallback.Remove(imsg);
FSocketIOEventCallbackRef.Remove(imsg);
Exit;
end;
{$ENDIF}
end;
//no error handler? than always raise an exception so programmer gets notified (and can log it using exception logger)
if error <> nil then
begin
if Assigned(DefaultErrorCallback) then
DefaultErrorCallback(ASocket, sErrorType, sErrorMsg)
else
raise ESocketIOException.CreateFmt('Server side error "%s": %s', [sErrorType, sErrorMsg]);
end;
if FSocketIOEventCallback.TryGetValue(imsg, callback) then
@ -1163,7 +1073,6 @@ begin
WriteString(ASocket, sresult);
end;
{$IFDEF SUPEROBJECT}
function TIdBaseSocketIOHandling.WriteSocketIOEventSync(const ASocket: ISocketIOContext; const aRoom, aEventName,
aJSONArray: string; aMaxwait_ms: Cardinal = INFINITE): ISuperObject;
var
@ -1248,7 +1157,7 @@ begin
promise.Free;
end;
end;
{$ENDIF}
procedure TIdBaseSocketIOHandling.WriteSocketIOJSON(const ASocket: ISocketIOContext;
const aRoom, aJSON: string; aCallback: TSocketIOCallbackRef = nil; const aOnError: TSocketIOError = nil);
var
@ -1405,7 +1314,8 @@ begin
inherited;
end;
procedure TSocketIOContext.EmitEvent(const aEventName, aData: string; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
procedure TSocketIOContext.EmitEvent(const aEventName, aData: string;
const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
begin
Assert(FHandling <> nil);
@ -1421,15 +1331,14 @@ begin
end;
end;
{$IFDEF SUPEROBJECT}
procedure TSocketIOContext.EmitEvent(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
procedure TSocketIOContext.EmitEvent(const aEventName: string; const aData: ISuperObject;
const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
begin
if aData <> nil then
EmitEvent(aEventName, aData.AsJSon, aCallback, aOnError)
else
EmitEvent(aEventName, '', aCallback, aOnError);
end;
{$ENDIF}
function TSocketIOContext.GetCustomData: TObject;
begin
@ -1498,7 +1407,8 @@ begin
Result := (FClient as TIdHTTPWebsocketClient).WSResourceName
end;
procedure TSocketIOContext.Send(const aData: string; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
procedure TSocketIOContext.Send(const aData: string;
const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
begin
if not Assigned(aCallback) then
FHandling.WriteSocketIOMsg(Self, '', aData)
@ -1512,7 +1422,6 @@ begin
end;
end;
{$IFDEF SUPEROBJECT}
procedure TSocketIOContext.SendJSON(const aJSON: ISuperObject;
const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
begin
@ -1527,7 +1436,7 @@ begin
end, aOnError);
end;
end;
{$ENDIF}
procedure TSocketIOContext.ServerContextDestroy(AContext: TIdContext);
begin
Self.Context := nil;
@ -1636,7 +1545,6 @@ end;
{ TIdSocketIOHandling }
{$IFDEF SUPEROBJECT}
procedure TIdSocketIOHandling.Emit(const aEventName: string;
const aData: ISuperObject; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
var
@ -1737,52 +1645,6 @@ begin
Result := WriteSocketIOEventSync(firstcontext, ''{no room}, aEventName, jsonarray, aMaxwait_ms);
end;
{$ENDIF}
procedure TIdSocketIOHandling.Emit(const aEventName: string;
const aData: string; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
var context: ISocketIOContext; isendcount: Integer;
begin
Lock;
try
isendcount := 0;
//note: client has single connection?
for context in FConnections.Values do
begin
if context.IsDisconnected then Continue;
if not Assigned(aCallback) then
WriteSocketIOEvent(context, ''{no room}, aEventName, aData, nil, nil)
else
WriteSocketIOEventRef(context, ''{no room}, aEventName, aData,
procedure(const aData: string)
begin
aCallback(context, SO(aData), nil);
end, aOnError);
Inc(isendcount);
end;
for context in FConnectionsGUID.Values do
begin
if context.IsDisconnected then Continue;
if not Assigned(aCallback) then
WriteSocketIOEvent(context, ''{no room}, aEventName, aData, nil, nil)
else
WriteSocketIOEventRef(context, ''{no room}, aEventName, aData,
procedure(const aData: string)
begin
aCallback(context, SO(aData), nil);
end, aOnError);
Inc(isendcount);
end;
if isendcount = 0 then
raise EIdSocketIoUnhandledMessage.Create('Cannot emit: no socket.io connections!');
finally
UnLock;
end;
end;
procedure TIdSocketIOHandling.Send(const aMessage: string;
const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError);
@ -1831,7 +1693,6 @@ begin
end;
end;
{ TSocketIOPromise }
procedure TSocketIOPromise.AfterConstruction;

127
IdWebsocketServer.pas
View file

@ -1,56 +1,35 @@
unit IdWebsocketServer;
interface
{$I wsdefines.pas}
uses
Classes
, IdStreamVCL
, IdGlobal
, IdWinsock2
, IdHTTPServer
, IdContext
, IdCustomHTTPServer
, IdHTTPWebBrokerBridge
//
, IdIOHandlerWebsocket
, IdServerIOHandlerWebsocket
, IdServerWebsocketContext
, IdServerWebsocketHandling
, IdServerSocketIOHandling
;
IdServerWebsocketHandling, IdServerSocketIOHandling, IdServerWebsocketContext,
IdHTTPServer, IdContext, IdCustomHTTPServer, Classes, IdIOHandlerWebsocket, IdGlobal, IdServerIOHandler;
type
TWebsocketMessageText = procedure(const AContext: TIdServerWSContext; const aText: string) of object;
TWebsocketMessageBin = procedure(const AContext: TIdServerWSContext; const aData: TStream) of object;
{$IFDEF WEBSOCKETBRIDGE}
TMyIdHttpWebBrokerBridge = class(TidHttpWebBrokerBridge)
published
property OnCreatePostStream;
property OnDoneWithPostStream;
property OnCommandGet;
end;
{$ENDIF}
{$IFDEF WEBSOCKETBRIDGE}
TIdWebsocketServer = class(TMyIdHttpWebBrokerBridge)
{$ELSE}
TIdWebsocketServer = class(TIdHTTPServer)
{$ENDIF}
private
FSocketIO: TIdServerSocketIOHandling_Ext;
FOnMessageText: TWebsocketMessageText;
FOnMessageBin: TWebsocketMessageBin;
FWriteTimeout: Integer;
FUseSSL: boolean;
function GetSocketIO: TIdServerSocketIOHandling;
procedure SetWriteTimeout(const Value: Integer);
function GetIOHandler: TIdServerIOHandler;
protected
function WebSocketCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo):boolean;
procedure DoCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); override;
procedure Startup; override;
procedure DetermineSSLforPort(APort: TIdPort; var VUseSSL: Boolean);
procedure DoCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo); override;
procedure ContextCreated(AContext: TIdContext); override;
procedure ContextDisconnected(AContext: TIdContext); override;
procedure WebsocketUpgradeRequest(const AContext: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo; var Accept:boolean); virtual;
procedure WebsocketChannelRequest(const AContext: TIdServerWSContext; var aType:TWSDataType; const aStrmRequest, aStrmResponse: TMemoryStream); virtual;
procedure WebsocketChannelRequest(const AContext: TIdServerWSContext; aType: TWSDataType; const aStrmRequest, aStrmResponse: TMemoryStream);
public
procedure AfterConstruction; override;
destructor Destroy; override;
@ -61,13 +40,18 @@ type
property OnMessageText: TWebsocketMessageText read FOnMessageText write FOnMessageText;
property OnMessageBin : TWebsocketMessageBin read FOnMessageBin write FOnMessageBin;
property IOHandler: TIdServerIOHandler read GetIOHandler write SetIOHandler;
property SocketIO: TIdServerSocketIOHandling read GetSocketIO;
published
property WriteTimeout: Integer read FWriteTimeout write SetWriteTimeout default 2000;
property UseSSL: boolean read FUseSSL write FUseSSL;
end;
implementation
uses
IdServerIOHandlerWebsocket, IdStreamVCL, Windows, IdWinsock2, IdSSLOpenSSL, IdSSL, IdThread; //, idIOHandler, idssl;
{ TIdWebsocketServer }
procedure TIdWebsocketServer.AfterConstruction;
@ -77,9 +61,6 @@ begin
FSocketIO := TIdServerSocketIOHandling_Ext.Create;
ContextClass := TIdServerWSContext;
if IOHandler = nil then
IOHandler := TIdServerIOHandlerWebsocket.Create(Self);
FWriteTimeout := 2 * 1000; //2s
end;
@ -105,23 +86,71 @@ begin
FSocketIO.Free;
end;
function TIdWebsocketServer.WebSocketCommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo):boolean;
procedure TIdWebsocketServer.DetermineSSLforPort(APort: TIdPort; var VUseSSL: Boolean);
//var
// thread: TIdThreadWithTask;
// ctx: TIdServerWSContext;
begin
(AContext as TIdServerWSContext).OnWebSocketUpgrade := Self.WebSocketUpgradeRequest;
(AContext as TIdServerWSContext).OnCustomChannelExecute := Self.WebsocketChannelRequest;
(AContext as TIdServerWSContext).SocketIO := FSocketIO;
VUseSSL := IOHandler.InheritsFrom(TIdServerIOHandlerSSLBase);
Result := TIdServerWebsocketHandling.ProcessServerCommandGet(AContext as TIdServerWSContext, ARequestInfo, AResponseInfo);
{$message warn 'todo: no ssl for localhost (testing, server IPC, etc)?'}
(*
//
if TThread.CurrentThread is TIdThreadWithTask then
begin
thread := TThread.CurrentThread as TIdThreadWithTask;
ctx := thread.Task as TIdServerWSContext;
//yarn := thread.Task.Yarn as TIdYarnOfThread;
if ctx.Binding.PeerIP = '127.0.0.1' then
VUseSSL := false;
end;
*)
end;
procedure TIdWebsocketServer.DoCommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
if not WebSocketCommandGet(AContext,ARequestInfo,AResponseInfo) then
(AContext as TIdServerWSContext).OnCustomChannelExecute := Self.WebsocketChannelRequest;
(AContext as TIdServerWSContext).SocketIO := FSocketIO;
if not TIdServerWebsocketHandling.ProcessServerCommandGet(AContext as TIdServerWSContext, ARequestInfo, AResponseInfo) then
inherited DoCommandGet(AContext, ARequestInfo, AResponseInfo);
end;
function TIdWebsocketServer.GetIOHandler: TIdServerIOHandler;
begin
Result := inherited IOHandler;
if Result = nil then
begin
if UseSSL then
begin
Result := TIdServerIOHandlerWebsocketSSL.Create(Self);
with Result as TIdServerIOHandlerWebsocketSSL do
begin
//note: custom certificate files must be set by user, e.g. in datamodule OnCreate:
//FHttpServer := TIdWebsocketServer.Create;
//FHttpServer.UseSSL := True;
//with FHttpServer.IOHandler as TIdServerIOHandlerWebsocketSSL do
// SSLOptions.RootCertFile := 'root.cer';
// SSLOptions.CertFile := 'your_cert.cer';
// SSLOptions.KeyFile := 'key.pem';
SSLOptions.Method := sslvSSLv23;
SSLOptions.Mode := sslmServer;
OnQuerySSLPort := DetermineSSLforPort;
end;
end
else
Result := TIdServerIOHandlerWebsocket.Create(Self);
inherited IOHandler := Result;
end;
end;
function TIdWebsocketServer.GetSocketIO: TIdServerSocketIOHandling;
begin
Result := FSocketIO;
@ -139,7 +168,7 @@ begin
begin
ctx := TIdServerWSContext(l.Items[i]);
Assert(ctx is TIdServerWSContext);
if ctx.IOHandler.IsWebsocket and
if ctx.WebsocketImpl.IsWebsocket and
not ctx.IsSocketIO
then
ctx.IOHandler.Write(aText);
@ -154,12 +183,14 @@ begin
FWriteTimeout := Value;
end;
procedure TIdWebsocketServer.WebsocketUpgradeRequest(const AContext: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo; var Accept:boolean);
procedure TIdWebsocketServer.Startup;
begin
Accept := True;
inherited;
end;
procedure TIdWebsocketServer.WebsocketChannelRequest(const AContext: TIdServerWSContext; var aType:TWSDataType; const aStrmRequest,aStrmResponse: TMemoryStream);
procedure TIdWebsocketServer.WebsocketChannelRequest(
const AContext: TIdServerWSContext; aType: TWSDataType; const aStrmRequest,
aStrmResponse: TMemoryStream);
var s: string;
begin
if aType = wdtText then
@ -191,7 +222,7 @@ begin
begin
ctx := TIdServerWSContext(l.Items[i]);
Assert(ctx is TIdServerWSContext);
if ctx.IOHandler.IsWebsocket and
if ctx.WebsocketImpl.IsWebsocket and
not ctx.IsSocketIO
then
ctx.IOHandler.Write(bytes);

7
README.md
View file

@ -1,10 +1,3 @@
# Not active anymore
Unfortunately I don't have time to support this project anymore. Also the websocket protocol has changed in the meantime, so it won't work with browser and other modern implementations.
Please take a look at the free (but closed) 3rd party component:
* http://www.esegece.com/websockets/download
* http://www.esegece.com/download/sgcWebSockets_free.zip
# DelphiWebsockets
Websockets and Socket.io for Delphi

3
wsdefines.pas
View file

@ -1,3 +0,0 @@
{ $DEFINE WEBSOCKETSSL}
{ $DEFINE WEBSOCKETBRIDGE}
{$DEFINE SUPEROBJECT}