From cdffdd25e14410dfb671709d8d4deeefa21eada0 Mon Sep 17 00:00:00 2001 From: sage-syfre Date: Fri, 28 Oct 2016 09:20:11 +0200 Subject: [PATCH] * Add defines for supporting SSL and HTTPBridge and removing SUPEROBJECT dependency Defines are defined in wsdefines.pas Removing SUPEROBJECT allow to release under MPL license (which i expect) Also fix * bug : framing encoding when sending a frame in multiple parts (fin=false) * bug : TIdIOHandlerWebsocket TIdIOHandlerWebsocket.ReadFrame _WaitByte ; may hang Other changes * Refactoring of TIdServerWebsocketHandling.ProcessServerCommandGet for inheritance * Add event (TIdServerWSContext) to accept or refuse upgrade (allow to check session cookie) * Change TWebsocketChannelRequest var aType:TWSDataType to allow receiving in a mode and answering in an other To use OpenSSL you need a modification in IdSSLOpenSSL to let overwrite TIdSSLIOHandlerSocketOpenSSL class --- DUnit/UnitTestWebsockets.dpr | 2 +- DUnit/mtTestWebSockets.pas | 14 +- IdHTTPWebsocketClient.pas | 16 +-- IdIOHandlerWebsocket.pas | 133 ++++++++++++------- IdServerIOHandlerWebsocket.pas | 38 +++++- IdServerSocketIOHandling.pas | 62 +++++---- IdServerWebsocketContext.pas | 23 ++-- IdServerWebsocketHandling.pas | 57 +++++---- IdSocketIOHandling.pas | 227 ++++++++++++++++++++++++++++----- IdWebsocketServer.pas | 65 +++++++--- 10 files changed, 457 insertions(+), 180 deletions(-) diff --git a/DUnit/UnitTestWebsockets.dpr b/DUnit/UnitTestWebsockets.dpr index c782959..a94a784 100644 --- a/DUnit/UnitTestWebsockets.dpr +++ b/DUnit/UnitTestWebsockets.dpr @@ -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} diff --git a/DUnit/mtTestWebSockets.pas b/DUnit/mtTestWebSockets.pas index 44ffaf5..c841f1c 100644 --- a/DUnit/mtTestWebSockets.pas +++ b/DUnit/mtTestWebSockets.pas @@ -156,7 +156,7 @@ begin //* client to server */ received := ''; IndyHTTPWebsocketServer1.SocketIO.OnEvent('TEST_EVENT', - procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: TSocketIOCallbackObj) + procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: ISocketIOCallback) 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: TSocketIOCallbackObj) + procedure(const ASocket: ISocketIOContext; const aArgument: TSuperArray; const aCallbackObj: ISocketIOCallback) 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: TSocketIOCallbackObj) + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: ISocketIOCallback) begin Abort; end; IndyHTTPWebsocketClient1.SocketIO.Send('test message', - procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: TSocketIOCallbackObj) + procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: ISocketIOCallback) 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: TSocketIOCallbackObj) + procedure(const ASocket: ISocketIOContext; const aJSON: ISuperObject; const aCallback: ISocketIOCallback) 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: TSocketIOCallbackObj) + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: ISocketIOCallback) 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: TSocketIOCallbackObj) + procedure(const ASocket: ISocketIOContext; const aText: string; const aCallback: ISocketIOCallback) begin FLastSocketIOMsg := aText; end; diff --git a/IdHTTPWebsocketClient.pas b/IdHTTPWebsocketClient.pas index 83ba9ed..1f374e1 100644 --- a/IdHTTPWebsocketClient.pas +++ b/IdHTTPWebsocketClient.pas @@ -1,23 +1,13 @@ 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; @@ -557,7 +547,11 @@ begin begin Request.Clear; Request.Connection := 'keep-alive'; + {$IFDEF WEBSOCKETSSL} + 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; diff --git a/IdIOHandlerWebsocket.pas b/IdIOHandlerWebsocket.pas index 33b6d21..5ae7bd4 100644 --- a/IdIOHandlerWebsocket.pas +++ b/IdIOHandlerWebsocket.pas @@ -1,17 +1,19 @@ unit IdIOHandlerWebsocket; - {.$DEFINE DEBUG_WS} - //The WebSocket Protocol, RFC 6455 //http://datatracker.ietf.org/doc/rfc6455/?include_text=1 - interface - +{$I wsdefines.pas} uses - Classes, SysUtils, - IdIOHandlerStack, IdGlobal, IdException, IdBuffer, - SyncObjs, - Generics.Collections; + Classes, SysUtils , SyncObjs , Generics.Collections + , IdIOHandlerStack + , IdGlobal + , IdException + , IdBuffer + {$IFDEF WEBSOCKETSSL} + , IdSSLOpenSSL + {$ENDIF} + ; type TWSDataType = (wdtText, wdtBinary); @@ -26,7 +28,19 @@ type TIdTextEncoding = IIdTextEncoding; {$ifend} + TIOWSPayloadInfo = Record + aPayloadLength: Cardinal; + aDataCode: TWSDataCode; + procedure Initialize(iTextMode:Boolean; iPayloadLength:Cardinal); + function DecLength(value:Cardinal):boolean; + procedure Clear; + end; + + {$IFDEF WEBSOCKETSSL} + TIdIOHandlerWebsocket = class(TIdSSLIOHandlerSocketOpenSSL) + {$ELSE} TIdIOHandlerWebsocket = class(TIdIOHandlerStack) + {$ENDIF} private FIsServerSide: Boolean; FBusyUpgrading: Boolean; @@ -44,9 +58,9 @@ type procedure SetIsWebsocket(const Value: Boolean); protected FMessageStream: TMemoryStream; - FWriteTextToTarget: Boolean; FCloseCodeSend: Boolean; FPendingWriteCount: Integer; + fPayloadInfo: TIOWSPayloadInfo; function InternalReadDataFromSource(var VBuffer: TIdBytes; ARaiseExceptionOnTimeout: Boolean): Integer; function ReadDataFromSource(var VBuffer: TIdBytes): Integer; override; @@ -60,6 +74,7 @@ type {$else} function UTF8Encoding: TEncoding; {$ifend} + procedure InitComponent; override; public function WriteData(aData: TIdBytes; aType: TWSDataCode; aFIN: boolean = true; aRSV1: boolean = false; aRSV2: boolean = false; aRSV3: boolean = false): integer; @@ -68,8 +83,6 @@ type property IsServerSide : Boolean read FIsServerSide write FIsServerSide; property ClientExtensionBits : TWSExtensionBits read FExtensionBits write FExtensionBits; public - class constructor Create; - procedure AfterConstruction;override; destructor Destroy; override; procedure Lock; @@ -229,15 +242,45 @@ begin end; end; +{ TIOWSPayloadInfo } + +procedure TIOWSPayloadInfo.Initialize(iTextMode:Boolean; iPayloadLength:Cardinal); +begin + aPayloadLength := iPayloadLength; + if iTextMode + then aDataCode := wdcText + else aDataCode := wdcBinary; +end; + +procedure TIOWSPayloadInfo.Clear; +begin + aPayloadLength := 0; + aDataCode := wdcBinary; +end; + +function TIOWSPayloadInfo.DecLength(value:Cardinal):boolean; +begin + if aPayloadLength >= value then + begin + aPayloadLength := aPayloadLength - value; + end + else aPayloadLength := 0; + aDataCode := wdcContinuation; + Result := aPayloadLength = 0; +end; + { TIdIOHandlerStack_Websocket } -procedure TIdIOHandlerWebsocket.AfterConstruction; +procedure TIdIOHandlerWebsocket.InitComponent; begin - inherited; + inherited ; FMessageStream := TMemoryStream.Create; FWSInputBuffer := TIdBuffer.Create; FLock := TCriticalSection.Create; FSelectLock := TCriticalSection.Create; + {$IFDEF WEBSOCKETSSL} + //SendBufferSize := 15 * 1024; + {$ENDIF} end; procedure TIdIOHandlerWebsocket.Clear; @@ -253,7 +296,7 @@ begin FCloseCode := 0; FLastActivityTime := 0; FLastPingTime := 0; - FWriteTextToTarget := False; + fPayloadInfo.Clear; FCloseCodeSend := False; FPendingWriteCount := 0; end; @@ -340,11 +383,6 @@ begin end; end; -class constructor TIdIOHandlerWebsocket.Create; -begin - //UseSingleWriteThread := True; -end; - destructor TIdIOHandlerWebsocket.Destroy; begin while FPendingWriteCount > 0 do @@ -400,8 +438,7 @@ begin SetLength(VBuffer, Result); end; -procedure TIdIOHandlerWebsocket.WriteLn(const AOut: string; - AEncoding: TIdTextEncoding); +procedure TIdIOHandlerWebsocket.WriteLn(const AOut:string; AEncoding: TIdTextEncoding); begin if UseSingleWriteThread and IsWebsocket and (GetCurrentThreadId <> TIdWebsocketWriteThread.Instance.ThreadID) then @@ -418,10 +455,10 @@ begin begin Lock; try - FWriteTextToTarget := True; + fPayloadInfo.Initialize(True,0); inherited WriteLn(AOut, UTF8Encoding); //must be UTF8! finally - FWriteTextToTarget := False; + fPayloadInfo.Clear; Unlock; end; end; @@ -445,10 +482,10 @@ begin begin Lock; try - FWriteTextToTarget := True; + fPayloadInfo.Initialize(True,0); inherited WriteLnRFC(AOut, UTF8Encoding); //must be UTF8! finally - FWriteTextToTarget := False; + fPayloadInfo.Clear; Unlock; end; end; @@ -472,10 +509,10 @@ begin begin Lock; try - FWriteTextToTarget := True; + fPayloadInfo.Initialize(True,0); inherited Write(AOut, UTF8Encoding); //must be UTF8! finally - FWriteTextToTarget := False; + fPayloadInfo.Clear; Unlock; end; end; @@ -499,10 +536,10 @@ begin begin Lock; try - FWriteTextToTarget := True; + fPayloadInfo.Initialize(True,0); inherited Write(AValue, AWriteLinesCount, UTF8Encoding); //must be UTF8! finally - FWriteTextToTarget := False; + fPayloadInfo.Clear; Unlock; end; end; @@ -526,10 +563,10 @@ begin begin Lock; try - FWriteTextToTarget := (aType = wdtText); + fPayloadInfo.Initialize((aType = wdtText),AStream.Size); inherited Write(AStream); finally - FWriteTextToTarget := False; + fPayloadInfo.Clear; Unlock; end; end; @@ -554,10 +591,8 @@ begin inherited WriteBufferFlush(AByteCount); end; -function TIdIOHandlerWebsocket.WriteDataToTarget(const ABuffer: TIdBytes; - const AOffset, ALength: Integer): Integer; -var - data: TIdBytes; +function TIdIOHandlerWebsocket.WriteDataToTarget(const ABuffer: TIdBytes; const AOffset, ALength: Integer): Integer; +var data: TIdBytes; DataCode:TWSDataCode; fin:boolean; begin if UseSingleWriteThread and IsWebsocket and (GetCurrentThreadId <> TIdWebsocketWriteThread.Instance.ThreadID) then Assert(False, 'Write done in different thread than TIdWebsocketWriteThread!'); @@ -584,12 +619,9 @@ begin {$ENDIF} try - if FWriteTextToTarget then - Result := WriteData(data, wdcText, True{send all at once}, - webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits) - else - Result := WriteData(data, wdcBinary, True{send all at once}, - webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits); + DataCode := fPayloadInfo.aDataCode; + fin := fPayloadInfo.DecLength(ALength); + Result := WriteData(data, DataCode, fin,webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits); except FClosedGracefully := True; Result := -1; @@ -853,7 +885,7 @@ var temp: TIdBytes; begin //if HasData then Exit(True); - if (FWSInputBuffer.Size > 0) then Exit(True); + if (FWSInputBuffer.Size > iInputPos) then Exit(True); Result := InternalReadDataFromSource(temp, ARaiseExceptionOnTimeout) > 0; if Result then @@ -1019,8 +1051,7 @@ begin {$ENDIF} end; -function TIdIOHandlerWebsocket.WriteData(aData: TIdBytes; - aType: TWSDataCode; aFIN, aRSV1, aRSV2, aRSV3: boolean): integer; +function TIdIOHandlerWebsocket.WriteData(aData:TIdBytes; aType:TWSDataCode; aFIN,aRSV1,aRSV2,aRSV3:boolean): integer; var iByte: Byte; i, ioffset: NativeInt; @@ -1051,7 +1082,7 @@ begin | |1|2|3| |K| | | +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + *) //FIN, RSV1, RSV2, RSV3: 1 bit each - if aFIN then iByte := (1 shl 7); + if aFIN then iByte := (1 shl 7) else iByte := 0; if aRSV1 then iByte := iByte + (1 shl 6); if aRSV2 then iByte := iByte + (1 shl 5); if aRSV3 then iByte := iByte + (1 shl 4); @@ -1137,7 +1168,17 @@ begin ioffset := 0; repeat //Result := Binding.Send(bData, ioffset); - Result := inherited WriteDataToTarget(bdata, iOffset, (Length(bData) - ioffset)); //ssl compatible? + // + Result := inherited WriteDataToTarget(bdata, iOffset, (Length(bData) - ioffset)); //ssl compatible? + if Result<0 then + begin + // IO error ; probably connexion closed by peer on protocol error ? + {$IFDEF DEBUG_WS} + if Debughook > 0 then + OutputDebugString(PChar(Format('WriteError ThrID:%d, L:%d, R:%d',[getcurrentthreadid,Length(bData)-ioffset,Result]))); + {$ENDIF} + break; + end; Inc(ioffset, Result); until ioffset >= Length(bData); diff --git a/IdServerIOHandlerWebsocket.pas b/IdServerIOHandlerWebsocket.pas index 80e1061..d2c9246 100644 --- a/IdServerIOHandlerWebsocket.pas +++ b/IdServerIOHandlerWebsocket.pas @@ -1,16 +1,33 @@ unit IdServerIOHandlerWebsocket; - interface - +{$I wsdefines.pas} uses - Classes, - IdServerIOHandlerStack, IdIOHandlerStack, IdGlobal, IdIOHandler, IdYarn, IdThread, IdSocketHandle, - IdIOHandlerWebsocket; + Classes + , IdServerIOHandlerStack + , IdIOHandlerStack + , IdGlobal + , IdIOHandler + , IdYarn + , IdThread + , IdSocketHandle + // + , IdIOHandlerWebsocket + {$IFDEF WEBSOCKETSSL} + , IdSSLOpenSSL + {$ENDIF} + ; 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; @@ -21,6 +38,13 @@ 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; begin @@ -35,18 +59,22 @@ end; procedure TIdServerIOHandlerWebsocket.InitComponent; begin inherited InitComponent; + {$IFNDEF WEBSOCKETSSL} IOHandlerSocketClass := TIdIOHandlerWebsocket; + {$ENDIF} 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; end; + {$ENDIF} end; end. diff --git a/IdServerSocketIOHandling.pas b/IdServerSocketIOHandling.pas index f913199..679dfd1 100644 --- a/IdServerSocketIOHandling.pas +++ b/IdServerSocketIOHandling.pas @@ -1,12 +1,18 @@ unit IdServerSocketIOHandling; - interface - +{$I wsdefines.pas} uses - IdContext, IdCustomTCPServer, - //IdServerWebsocketContext, - Classes, Generics.Collections, - superobject, IdException, IdServerBaseHandling, IdSocketIOHandling; + Classes, Generics.Collections, SysUtils, StrUtils + , IdContext + , IdCustomTCPServer + , IdException + // + {$IFDEF SUPEROBJECT} + , superobject + {$ENDIF} + , IdServerBaseHandling + , IdSocketIOHandling + ; type TIdServerSocketIOHandling = class(TIdBaseSocketIOHandling) @@ -15,22 +21,27 @@ 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: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil): Integer;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; + {$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; + procedure EmitEventTo (const aContext: ISocketIOContext; + const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil; const aOnError: TSocketIOError = nil);overload; + {$ENDIF} 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); @@ -72,6 +83,16 @@ 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; @@ -125,21 +146,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; - -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 diff --git a/IdServerWebsocketContext.pas b/IdServerWebsocketContext.pas index b7159cb..4468a56 100644 --- a/IdServerWebsocketContext.pas +++ b/IdServerWebsocketContext.pas @@ -1,16 +1,22 @@ unit IdServerWebsocketContext; - interface - +{$I wsdefines.pas} uses - Classes, - IdCustomTCPServer, IdIOHandlerWebsocket, - IdServerBaseHandling, IdServerSocketIOHandling, IdContext; + Classes, strUtils + , IdContext + , IdCustomTCPServer + , IdCustomHTTPServer + // + , IdIOHandlerWebsocket + , IdServerBaseHandling + , IdServerSocketIOHandling + ; type TIdServerWSContext = class; - TWebsocketChannelRequest = procedure(const AContext: TIdServerWSContext; aType: TWSDataType; const strmRequest, strmResponse: TMemoryStream) of object; + 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; TIdServerWSContext = class(TIdServerContext) private @@ -25,6 +31,7 @@ type FWebSocketExtensions: string; FCookie: string; //FSocketIOPingSend: Boolean; + fOnWebSocketUpgrade: TWebSocketUpgradeEvent; FOnCustomChannelExecute: TWebsocketChannelRequest; FSocketIO: TIdServerSocketIOHandling; FOnDestroy: TIdContextEvent; @@ -50,14 +57,12 @@ 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; diff --git a/IdServerWebsocketHandling.pas b/IdServerWebsocketHandling.pas index f1f6f52..3b78f15 100644 --- a/IdServerWebsocketHandling.pas +++ b/IdServerWebsocketHandling.pas @@ -1,16 +1,24 @@ unit IdServerWebsocketHandling; - interface - +{$I wsdefines.pas} uses - IdContext, IdCustomHTTPServer, + Classes, StrUtils, SysUtils, DateUtils + , IdCoderMIME + , IdThread + , IdContext + , IdCustomHTTPServer {$IF CompilerVersion <= 21.0} //D2010 - IdHashSHA1, + , IdHashSHA1 {$else} - IdHashSHA, //XE3 etc + , IdHashSHA //XE3 etc {$IFEND} - IdServerSocketIOHandling, IdServerWebsocketContext, - Classes, IdServerBaseHandling, IdIOHandlerWebsocket, IdSocketIOHandling; + , IdServerSocketIOHandling + // + , IdSocketIOHandling + , IdServerBaseHandling + , IdServerWebsocketContext + , IdIOHandlerWebsocket + ; type TIdServerSocketIOHandling_Ext = class(TIdServerSocketIOHandling) @@ -19,7 +27,7 @@ type TIdServerWebsocketHandling = class(TIdServerBaseHandling) protected class procedure DoWSExecute(AThread: TIdContext; aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual; - class procedure HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType; + class procedure HandleWSMessage(AContext: TIdServerWSContext; var aType: TWSDataType; aRequestStrm, aResponseStrm: TMemoryStream; aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual; public @@ -31,10 +39,6 @@ type implementation -uses - StrUtils, SysUtils, DateUtils, - IdCustomTCPServer, IdCoderMIME, IdThread; - { TIdServerWebsocketHandling } class function TIdServerWebsocketHandling.CurrentSocket: ISocketIOContext; @@ -103,23 +107,20 @@ begin Continue; end; - if wscode = wdcText then - wstype := wdtText - else - wstype := wdtBinary; + if wscode = wdcText + then wstype := wdtText + else wstype := wdtBinary; HandleWSMessage(context, wstype, strmRequest, strmResponse, aSocketIOHandler); //write result back (of the same type: text or bin) if strmResponse.Size > 0 then begin - if wscode = wdcText then - context.IOHandler.Write(strmResponse, wdtText) - else - context.IOHandler.Write(strmResponse, wdtBinary) + if wstype = wdtText + then context.IOHandler.Write(strmResponse, wdtText) + else context.IOHandler.Write(strmResponse, wdtBinary) end - else - context.IOHandler.WriteData(nil, wdcPing); + else context.IOHandler.WriteData(nil, wdcPing); finally strmRequest.Free; strmResponse.Free; @@ -152,9 +153,7 @@ begin end; end; -class procedure TIdServerWebsocketHandling.HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType; - aRequestStrm, aResponseStrm: TMemoryStream; - aSocketIOHandler: TIdServerSocketIOHandling_Ext); +class procedure TIdServerWebsocketHandling.HandleWSMessage(AContext: TIdServerWSContext; var aType:TWSDataType; aRequestStrm, aResponseStrm: TMemoryStream; aSocketIOHandler: TIdServerSocketIOHandling_Ext); begin if AContext.IsSocketIO then begin @@ -170,6 +169,7 @@ class function TIdServerWebsocketHandling.ProcessServerCommandGet( AThread: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo): Boolean; var + Accept: Boolean; sValue, squid: string; context: TIdServerWSContext; hash: TIdHashSHA1; @@ -244,6 +244,13 @@ 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 diff --git a/IdSocketIOHandling.pas b/IdSocketIOHandling.pas index 7a7acf1..9414935 100644 --- a/IdSocketIOHandling.pas +++ b/IdSocketIOHandling.pas @@ -1,14 +1,24 @@ unit IdSocketIOHandling; - interface - +{$I wsdefines.pas} uses - Classes, Generics.Collections, - superobject, - IdServerBaseHandling, IdContext, IdException, IdIOHandlerWebsocket, IdHTTP, - SyncObjs, SysUtils; + windows, SyncObjs, SysUtils, StrUtils, Classes, Generics.Collections + {$IFDEF SUPEROBJECT} + , superobject + {$ENDIF} + , IdContext + , IdException + , IdHTTP + // + , IdServerBaseHandling + , IdIOHandlerWebsocket + ; type + {$IFNDEF SUPEROBJECT} + TSuperArray = String; + {$ENDIF} + TSocketIOContext = class; TSocketIOCallbackObj = class; TIdBaseSocketIOHandling = class; @@ -18,9 +28,13 @@ 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); - TSocketIONotify = reference to procedure(const ASocket: ISocketIOContext); + {$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); TSocketIOError = reference to procedure(const ASocket: ISocketIOContext; const aErrorClass, aErrorMessage: string); TSocketIOEventError = reference to procedure(const ASocket: ISocketIOContext; const aCallback: ISocketIOCallback; E: Exception); @@ -48,14 +62,15 @@ 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; @@ -104,14 +119,15 @@ 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 @@ -137,7 +153,9 @@ type protected Done, Success: Boolean; Error: Exception; + {$IFDEF SUPEROBJECT} Data : ISuperObject; + {$ENDIF} Event: TEvent; public procedure AfterConstruction; override; @@ -158,7 +176,9 @@ type FOnDisconnectList: TSocketIONotifyList; FOnEventList: TObjectDictionary; FOnSocketIOMsg: TSocketIOMsg; + {$IFDEF SUPEROBJECT} FOnSocketIOJson: TSocketIOMsgJSON; + {$ENDIF} procedure ProcessEvent(const AContext: ISocketIOContext; const aText: string; aMsgNr: Integer; aHasCallback: Boolean); private @@ -186,7 +206,9 @@ 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); @@ -215,7 +237,9 @@ 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); @@ -228,15 +252,29 @@ 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 - StrUtils, IdServerWebsocketContext, IdHTTPWebsocketClient, Windows; + IdServerWebsocketContext, IdHTTPWebsocketClient; + +{$IFNDEF SUPEROBJECT} +function SO(const S:string):string; inline; +begin + Result := S; +end; +{$ENDIF} procedure TIdBaseSocketIOHandling.AfterConstruction; begin @@ -502,8 +540,7 @@ 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 @@ -523,26 +560,86 @@ 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 - json: ISuperObject; name: string; + {$IFNDEF SUPEROBJECT} + args: string; + {$ELSE} args: TSuperArray; + json: ISuperObject; + // socket: TSocketIOContext; + {$ENDIF} list: TSocketIOEventList; event: TSocketIOEvent; callback: ISocketIOCallback; -// socket: TSocketIOContext; + + {$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} + 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; + // args := nil; try name := json.S['name']; //"my other event args := json.A['args']; //[{"my":"data"}] + {$ENDIF} if FOnEventList.TryGetValue(name, list) then begin @@ -563,7 +660,11 @@ begin OnEventError(AContext, callback, e) 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; @@ -571,10 +672,13 @@ begin end else raise EIdSocketIoUnhandledMessage.Create(aText); + + {$IFDEF SUPEROBJECT} finally -// args.Free; - json := nil; +//args.Free; + json := nil; end; + {$ENDIF} end; procedure TIdBaseSocketIOHandling.ProcessHeatbeatRequest(const ASocket: ISocketIOContext; const aText: string); @@ -749,7 +853,9 @@ var callbackref: TSocketIOCallbackRef; callbackobj: ISocketIOCallback; errorref: TSocketIOError; + {$IFDEF SUPEROBJECT} error: ISuperObject; + {$ENDIF} socket: TSocketIOContext; begin if ASocket = nil then Exit; @@ -822,8 +928,12 @@ 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 @@ -841,6 +951,7 @@ begin //4:1::{"a":"b"} else if StartsStr('4:', str) then begin + {$IFDEF SUPEROBJECT} if Assigned(OnSocketIOJson) then begin if bCallback then @@ -864,6 +975,7 @@ begin OnSocketIOJson(ASocket, SO(sdata), nil); //, imsg, bCallback); end else + {$ENDIF} raise EIdSocketIoUnhandledMessage.Create(str); end //(5) Event @@ -895,6 +1007,7 @@ begin begin FSocketIOErrorRef.Remove(imsg); //'[{"Error":{"Message":"Operation aborted","Type":"EAbort"}}]' + {$IFDEF SUPEROBJECT} if ContainsText(sdata, '{"Error":') then begin error := SO(sdata); @@ -910,6 +1023,7 @@ begin FSocketIOEventCallbackRef.Remove(imsg); Exit; end; + {$ENDIF} end; if FSocketIOEventCallback.TryGetValue(imsg, callback) then @@ -1049,6 +1163,7 @@ begin WriteString(ASocket, sresult); end; +{$IFDEF SUPEROBJECT} function TIdBaseSocketIOHandling.WriteSocketIOEventSync(const ASocket: ISocketIOContext; const aRoom, aEventName, aJSONArray: string; aMaxwait_ms: Cardinal = INFINITE): ISuperObject; var @@ -1133,7 +1248,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 @@ -1290,8 +1405,7 @@ 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); @@ -1307,14 +1421,15 @@ begin end; end; -procedure TSocketIOContext.EmitEvent(const aEventName: string; const aData: ISuperObject; - const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); +{$IFDEF SUPEROBJECT} +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 @@ -1383,8 +1498,7 @@ 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) @@ -1398,6 +1512,7 @@ begin end; end; +{$IFDEF SUPEROBJECT} procedure TSocketIOContext.SendJSON(const aJSON: ISuperObject; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); begin @@ -1412,7 +1527,7 @@ begin end, aOnError); end; end; - +{$ENDIF} procedure TSocketIOContext.ServerContextDestroy(AContext: TIdContext); begin Self.Context := nil; @@ -1521,6 +1636,7 @@ end; { TIdSocketIOHandling } +{$IFDEF SUPEROBJECT} procedure TIdSocketIOHandling.Emit(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON; const aOnError: TSocketIOError); var @@ -1621,6 +1737,52 @@ 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); @@ -1669,6 +1831,7 @@ begin end; end; + { TSocketIOPromise } procedure TSocketIOPromise.AfterConstruction; diff --git a/IdWebsocketServer.pas b/IdWebsocketServer.pas index 4062c8c..3b5d788 100644 --- a/IdWebsocketServer.pas +++ b/IdWebsocketServer.pas @@ -1,16 +1,41 @@ unit IdWebsocketServer; - interface - +{$I wsdefines.pas} uses - IdServerWebsocketHandling, IdServerSocketIOHandling, IdServerWebsocketContext, - IdHTTPServer, IdContext, IdCustomHTTPServer, Classes, IdIOHandlerWebsocket; + Classes + , IdStreamVCL + , IdGlobal + , IdWinsock2 + , IdHTTPServer + , IdContext + , IdCustomHTTPServer + , IdHTTPWebBrokerBridge + // + , IdIOHandlerWebsocket + , IdServerIOHandlerWebsocket + , IdServerWebsocketContext + , IdServerWebsocketHandling + , IdServerSocketIOHandling + ; 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; @@ -19,12 +44,13 @@ type function GetSocketIO: TIdServerSocketIOHandling; procedure SetWriteTimeout(const Value: Integer); protected - procedure DoCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; - AResponseInfo: TIdHTTPResponseInfo); override; + function WebSocketCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo):boolean; + procedure DoCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); override; procedure ContextCreated(AContext: TIdContext); override; procedure ContextDisconnected(AContext: TIdContext); override; - procedure WebsocketChannelRequest(const AContext: TIdServerWSContext; aType: TWSDataType; const aStrmRequest, aStrmResponse: TMemoryStream); + procedure WebsocketUpgradeRequest(const AContext: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo; var Accept:boolean); virtual; + procedure WebsocketChannelRequest(const AContext: TIdServerWSContext; var aType:TWSDataType; const aStrmRequest, aStrmResponse: TMemoryStream); virtual; public procedure AfterConstruction; override; destructor Destroy; override; @@ -42,9 +68,6 @@ type implementation -uses - IdServerIOHandlerWebsocket, IdStreamVCL, IdGlobal, Windows, IdWinsock2; - { TIdWebsocketServer } procedure TIdWebsocketServer.AfterConstruction; @@ -82,13 +105,20 @@ begin FSocketIO.Free; end; -procedure TIdWebsocketServer.DoCommandGet(AContext: TIdContext; - ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); +function TIdWebsocketServer.WebSocketCommandGet(AContext: TIdContext; + ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo):boolean; begin + (AContext as TIdServerWSContext).OnWebSocketUpgrade := Self.WebSocketUpgradeRequest; (AContext as TIdServerWSContext).OnCustomChannelExecute := Self.WebsocketChannelRequest; (AContext as TIdServerWSContext).SocketIO := FSocketIO; - if not TIdServerWebsocketHandling.ProcessServerCommandGet(AContext as TIdServerWSContext, ARequestInfo, AResponseInfo) then + Result := TIdServerWebsocketHandling.ProcessServerCommandGet(AContext as TIdServerWSContext, ARequestInfo, AResponseInfo); +end; + +procedure TIdWebsocketServer.DoCommandGet(AContext: TIdContext; + ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); +begin + if not WebSocketCommandGet(AContext,ARequestInfo,AResponseInfo) then inherited DoCommandGet(AContext, ARequestInfo, AResponseInfo); end; @@ -124,9 +154,12 @@ begin FWriteTimeout := Value; end; -procedure TIdWebsocketServer.WebsocketChannelRequest( - const AContext: TIdServerWSContext; aType: TWSDataType; const aStrmRequest, - aStrmResponse: TMemoryStream); +procedure TIdWebsocketServer.WebsocketUpgradeRequest(const AContext: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo; var Accept:boolean); +begin + Accept := True; +end; + +procedure TIdWebsocketServer.WebsocketChannelRequest(const AContext: TIdServerWSContext; var aType:TWSDataType; const aStrmRequest,aStrmResponse: TMemoryStream); var s: string; begin if aType = wdtText then