first checkin

This commit is contained in:
andremussche 2013-11-11 21:14:42 +01:00
commit 7d3b78b227
9 changed files with 4053 additions and 0 deletions

1238
IdHTTPWebsocketClient.pas Normal file

File diff suppressed because it is too large Load diff

771
IdIOHandlerWebsocket.pas Normal file
View file

@ -0,0 +1,771 @@
unit IdIOHandlerWebsocket;
//The WebSocket Protocol, RFC 6455
//http://datatracker.ietf.org/doc/rfc6455/?include_text=1
interface
uses
Classes,
IdIOHandlerStack, IdGlobal, IdException, IdBuffer, SyncObjs,
Generics.Collections;
type
TWSDataType = (wdtText, wdtBinary);
TWSDataCode = (wdcNone, wdcContinuation, wdcText, wdcBinary, wdcClose, wdcPing, wdcPong);
TWSExtensionBit = (webBit1, webBit2, webBit3);
TWSExtensionBits = set of TWSExtensionBit;
TIdIOHandlerWebsocket = class;
EIdWebSocketHandleError = class(EIdSocketHandleError);
TIdIOHandlerWebsocket = class(TIdIOHandlerStack)
private
FIsServerSide: Boolean;
FBusyUpgrading: Boolean;
FIsWebsocket: Boolean;
FWSInputBuffer: TIdBuffer;
FExtensionBits: TWSExtensionBits;
FLock: TCriticalSection;
FCloseReason: string;
FCloseCode: Integer;
FClosing: Boolean;
protected
FMessageStream: TMemoryStream;
FWriteTextToTarget: Boolean;
FCloseCodeSend: Boolean;
function InternalReadDataFromSource(var VBuffer: TIdBytes): Integer;
function ReadDataFromSource(var VBuffer: TIdBytes): Integer; override;
function WriteDataToTarget (const ABuffer: TIdBytes; const AOffset, ALength: Integer): Integer; override;
function ReadFrame(out aFIN, aRSV1, aRSV2, aRSV3: boolean; out aDataCode: TWSDataCode; out aData: TIdBytes): Integer;
function ReadMessage(var aBuffer: TIdBytes; out aDataCode: TWSDataCode): Integer;
public
function WriteData(aData: TIdBytes; aType: TWSDataCode;
aFIN: boolean = true; aRSV1: boolean = false; aRSV2: boolean = false; aRSV3: boolean = false): integer;
property BusyUpgrading : Boolean read FBusyUpgrading write FBusyUpgrading;
property IsWebsocket : Boolean read FIsWebsocket write FIsWebsocket;
property IsServerSide : Boolean read FIsServerSide write FIsServerSide;
property ClientExtensionBits : TWSExtensionBits read FExtensionBits write FExtensionBits;
public
procedure AfterConstruction;override;
destructor Destroy; override;
procedure Lock;
procedure Unlock;
function TryLock: Boolean;
procedure Close; override;
property Closing : Boolean read FClosing;
property CloseCode : Integer read FCloseCode write FCloseCode;
property CloseReason: string read FCloseReason write FCloseReason;
//text/string writes
procedure Write(const AOut: string; AEncoding: TIdTextEncoding = nil); overload; override;
procedure WriteLn(const AOut: string; AEncoding: TIdTextEncoding = nil); overload; override;
procedure WriteLnRFC(const AOut: string = ''; AEncoding: TIdTextEncoding = nil); override;
procedure Write(AValue: TStrings; AWriteLinesCount: Boolean = False; AEncoding: TIdTextEncoding = nil); overload; override;
procedure Write(AStream: TStream; aType: TWSDataType); overload;
end;
//close frame codes
const
C_FrameClose_Normal = 1000; //1000 indicates a normal closure, meaning that the purpose for
//which the connection was established has been fulfilled.
C_FrameClose_GoingAway = 1001; //1001 indicates that an endpoint is "going away", such as a server
//going down or a browser having navigated away from a page.
C_FrameClose_ProtocolError = 1002; //1002 indicates that an endpoint is terminating the connection due
//to a protocol error.
C_FrameClose_UnhandledDataType = 1003; //1003 indicates that an endpoint is terminating the connection
//because it has received a type of data it cannot accept (e.g., an
//endpoint that understands only text data MAY send this if it
//receives a binary message).
C_FrameClose_Reserved = 1004; //Reserved. The specific meaning might be defined in the future.
C_FrameClose_ReservedNoStatus = 1005; //1005 is a reserved value and MUST NOT be set as a status code in a
//Close control frame by an endpoint. It is designated for use in
//applications expecting a status code to indicate that no status
//code was actually present.
C_FrameClose_ReservedAbnormal = 1006; //1006 is a reserved value and MUST NOT be set as a status code in a
//Close control frame by an endpoint. It is designated for use in
//applications expecting a status code to indicate that the
//connection was closed abnormally, e.g., without sending or
//receiving a Close control frame.
C_FrameClose_InconsistentData = 1007; //1007 indicates that an endpoint is terminating the connection
//because it has received data within a message that was not
//consistent with the type of the message (e.g., non-UTF-8 [RFC3629]
//data within a text message).
C_FrameClose_PolicyError = 1008; //1008 indicates that an endpoint is terminating the connection
//because it has received a message that violates its policy. This
//is a generic status code that can be returned when there is no
//other more suitable status code (e.g., 1003 or 1009) or if there
//is a need to hide specific details about the policy.
C_FrameClose_ToBigMessage = 1009; //1009 indicates that an endpoint is terminating the connection
//because it has received a message that is too big for it to process.
C_FrameClose_MissingExtenstion = 1010; //1010 indicates that an endpoint (client) is terminating the
//connection because it has expected the server to negotiate one or
//more extension, but the server didn't return them in the response
//message of the WebSocket handshake. The list of extensions that
//are needed SHOULD appear in the /reason/ part of the Close frame.
//Note that this status code is not used by the server, because it
//can fail the WebSocket handshake instead.
C_FrameClose_UnExpectedError = 1011; //1011 indicates that a server is terminating the connection because
//it encountered an unexpected condition that prevented it from
//fulfilling the request.
C_FrameClose_ReservedTLSError = 1015; //1015 is a reserved value and MUST NOT be set as a status code in a
//Close control frame by an endpoint. It is designated for use in
//applications expecting a status code to indicate that the
//connection was closed due to a failure to perform a TLS handshake
//(e.g., the server certificate can't be verified).
implementation
uses
SysUtils, Math, IdStream, IdStack, IdWinsock2, IdExceptionCore,
IdResourceStrings, IdResourceStringsCore;
//frame codes
const
C_FrameCode_Continuation = 0;
C_FrameCode_Text = 1;
C_FrameCode_Binary = 2;
//3-7 are reserved for further non-control frames
C_FrameCode_Close = 8;
C_FrameCode_Ping = 9;
C_FrameCode_Pong = 10 {A};
//B-F are reserved for further control frames
{ TIdIOHandlerStack_Websocket }
procedure TIdIOHandlerWebsocket.AfterConstruction;
begin
inherited;
FMessageStream := TMemoryStream.Create;
FWSInputBuffer := TIdBuffer.Create;
FLock := TCriticalSection.Create;
end;
procedure TIdIOHandlerWebsocket.Close;
var
iaWriteBuffer: TIdBytes;
sReason: UTF8String;
iOptVal, iOptLen: Integer;
bConnected: Boolean;
begin
try
//valid connection?
bConnected := Opened and
SourceIsAvailable and
not ClosedGracefully;
//no socket error? connection closed by software abort, connection reset by peer, etc
iOptLen := SIZE_INTEGER;
bConnected := bConnected and
(IdWinsock2.getsockopt(Self.Binding.Handle, SOL_SOCKET, SO_ERROR, PAnsiChar(@iOptVal), iOptLen) = 0) and
(iOptVal = 0);
if bConnected and IsWebsocket then
begin
//close message must be responded with a close message back
//or initiated with a close message
if not FCloseCodeSend then
begin
FCloseCodeSend := True;
//we initiate the close? then write reason etc
if not Closing then
begin
SetLength(iaWriteBuffer, 2);
if CloseCode < C_FrameClose_Normal then
CloseCode := C_FrameClose_Normal;
iaWriteBuffer[0] := Byte(CloseCode shr 8);
iaWriteBuffer[1] := Byte(CloseCode);
if CloseReason <> '' then
begin
sReason := utf8string(CloseReason);
SetLength(iaWriteBuffer, Length(iaWriteBuffer) + Length(sReason));
Move(sReason[1], iaWriteBuffer[2], Length(sReason));
end;
end
else
begin
//just send normal close response back
SetLength(iaWriteBuffer, 2);
iaWriteBuffer[0] := Byte(C_FrameClose_Normal shr 8);
iaWriteBuffer[1] := Byte(C_FrameClose_Normal);
end;
WriteData(iaWriteBuffer, wdcClose); //send close + code back
end;
//we did initiate the close? then wait (a little) for close response
if not Closing then
begin
FClosing := True;
CheckForDisconnect();
//wait till client respond with close message back
//but a pending message can be in the buffer, so process this too
while ReadFromSource(False{no disconnect error}, 1 * 1000, False) > 0 do ; //response within 1s?
end;
end;
except
//ignore, it's possible that the client is disconnected already (crashed etc)
end;
IsWebsocket := False;
BusyUpgrading := False;
inherited Close;
end;
destructor TIdIOHandlerWebsocket.Destroy;
begin
FLock.Enter;
FLock.Free;
FWSInputBuffer.Free;
FMessageStream.Free;
inherited;
end;
function TIdIOHandlerWebsocket.InternalReadDataFromSource(
var VBuffer: TIdBytes): Integer;
begin
CheckForDisconnect;
if not Readable(ReadTimeout) or
not Opened or
not SourceIsAvailable then
begin
CheckForDisconnect; //disconnected during wait in "Readable()"?
if not Opened then
EIdNotConnected.Toss(RSNotConnected)
else if not SourceIsAvailable then
EIdClosedSocket.Toss(RSStatusDisconnected);
GStack.CheckForSocketError(GStack.WSGetLastError); //check for socket error
EIdReadTimeout.Toss(RSIdNoDataToRead); //exit, no data can be received
end;
SetLength(VBuffer, RecvBufferSize);
Result := inherited ReadDataFromSource(VBuffer);
if Result = 0 then
begin
CheckForDisconnect; //disconnected in the mean time?
GStack.CheckForSocketError(GStack.WSGetLastError); //check for socket error
EIdNoDataToRead.Toss(RSIdNoDataToRead); //nothing read? then connection is probably closed -> exit
end;
SetLength(VBuffer, Result);
end;
procedure TIdIOHandlerWebsocket.WriteLn(const AOut: string;
AEncoding: TIdTextEncoding);
begin
FWriteTextToTarget := True;
try
inherited WriteLn(AOut, TIdTextEncoding.UTF8); //must be UTF8!
finally
FWriteTextToTarget := False;
end;
end;
procedure TIdIOHandlerWebsocket.WriteLnRFC(const AOut: string;
AEncoding: TIdTextEncoding);
begin
FWriteTextToTarget := True;
try
inherited WriteLnRFC(AOut, TIdTextEncoding.UTF8); //must be UTF8!
finally
FWriteTextToTarget := False;
end;
end;
procedure TIdIOHandlerWebsocket.Write(const AOut: string;
AEncoding: TIdTextEncoding);
begin
FWriteTextToTarget := True;
try
inherited Write(AOut, TIdTextEncoding.UTF8); //must be UTF8!
finally
FWriteTextToTarget := False;
end;
end;
procedure TIdIOHandlerWebsocket.Write(AValue: TStrings;
AWriteLinesCount: Boolean; AEncoding: TIdTextEncoding);
begin
FWriteTextToTarget := True;
try
inherited Write(AValue, AWriteLinesCount, TIdTextEncoding.UTF8); //must be UTF8!
finally
FWriteTextToTarget := False;
end;
end;
procedure TIdIOHandlerWebsocket.Write(AStream: TStream;
aType: TWSDataType);
begin
FWriteTextToTarget := (aType = wdtText);
try
inherited Write(AStream);
finally
FWriteTextToTarget := False;
end;
end;
function TIdIOHandlerWebsocket.WriteDataToTarget(const ABuffer: TIdBytes;
const AOffset, ALength: Integer): Integer;
begin
if not IsWebsocket then
Result := inherited WriteDataToTarget(ABuffer, AOffset, ALength)
else
begin
Lock;
try
if FWriteTextToTarget then
Result := WriteData(ABuffer, wdcText, True{send all at once},
webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits)
else
Result := WriteData(ABuffer, wdcBinary, True{send all at once},
webBit1 in ClientExtensionBits, webBit2 in ClientExtensionBits, webBit3 in ClientExtensionBits);
except
Unlock; //always unlock when socket exception
FClosedGracefully := True;
Raise;
end;
Unlock; //normal unlock (no double try finally)
end;
end;
function TIdIOHandlerWebsocket.ReadDataFromSource(
var VBuffer: TIdBytes): Integer;
var
wscode: TWSDataCode;
begin
//the first time something is read AFTER upgrading, we switch to WS
//(so partial writes can be done, till a read is done)
if BusyUpgrading then
begin
BusyUpgrading := False;
IsWebsocket := True;
end;
if not IsWebsocket then
Result := inherited ReadDataFromSource(VBuffer)
else
begin
Lock;
try
//we wait till we have a full message here (can be fragmented in several frames)
Result := ReadMessage(VBuffer, wscode);
//first write the data code (text or binary, ping, pong)
FInputBuffer.Write(LongWord(Ord(wscode)));
//we write message size here, vbuffer is written after this. This way we can use ReadStream to get 1 single message (in case multiple messages in FInputBuffer)
if LargeStream then
FInputBuffer.Write(Int64(Result))
else
FInputBuffer.Write(LongWord(Result))
except
Unlock; //always unlock when socket exception
FClosedGracefully := True; //closed (but not gracefully?)
Raise;
end;
Unlock; //normal unlock (no double try finally)
end;
end;
function TIdIOHandlerWebsocket.ReadMessage(var aBuffer: TIdBytes; out aDataCode: TWSDataCode): Integer;
var
iReadCount: Integer;
iaReadBuffer: TIdBytes;
bFIN, bRSV1, bRSV2, bRSV3: boolean;
lDataCode: TWSDataCode;
lFirstDataCode: TWSDataCode;
// closeCode: integer;
// closeResult: string;
begin
Result := 0;
(* ...all fragments of a message are of
the same type, as set by the first fragment's opcode. Since
control frames cannot be fragmented, the type for all fragments in
a message MUST be either text, binary, or one of the reserved
opcodes. *)
lFirstDataCode := wdcNone;
FMessageStream.Clear;
repeat
//read a single frame
iReadCount := ReadFrame(bFIN, bRSV1, bRSV2, bRSV3, lDataCode, iaReadBuffer);
if (iReadCount > 0) or
(lDataCode <> wdcNone) then
begin
Assert(Length(iaReadBuffer) = iReadCount);
//store client extension bits
if Self.IsServerSide then
begin
ClientExtensionBits := [];
if bRSV1 then ClientExtensionBits := ClientExtensionBits + [webBit1];
if bRSV2 then ClientExtensionBits := ClientExtensionBits + [webBit2];
if bRSV3 then ClientExtensionBits := ClientExtensionBits + [webBit3];
end;
//process frame
case lDataCode of
wdcText, wdcBinary:
begin
if lFirstDataCode <> wdcNone then
raise EIdWebSocketHandleError.Create('Invalid frame: specified data code only allowed for the first frame');
lFirstDataCode := lDataCode;
FMessageStream.Clear;
TIdStreamHelper.Write(FMessageStream, iaReadBuffer);
end;
wdcContinuation:
begin
if not (lFirstDataCode in [wdcText, wdcBinary]) then
raise EIdWebSocketHandleError.Create('Invalid frame continuation');
TIdStreamHelper.Write(FMessageStream, iaReadBuffer);
end;
wdcClose:
begin
FCloseCode := C_FrameClose_Normal;
//"If there is a body, the first two bytes of the body MUST be a 2-byte
// unsigned integer (in network byte order) representing a status code"
if Length(iaReadBuffer) > 1 then
begin
FCloseCode := (iaReadBuffer[0] shl 8) +
iaReadBuffer[1];
if Length(iaReadBuffer) > 2 then
FCloseReason := BytesToString(iaReadBuffer, 2, Length(iaReadBuffer), TEncoding.UTF8);
end;
FClosing := True;
Self.Close;
end;
//Note: control frames can be send between fragmented frames
wdcPing:
begin
WriteData(iaReadBuffer, wdcPong); //send pong + same data back
lFirstDataCode := lDataCode;
//bFIN := False; //ignore ping when we wait for data?
end;
wdcPong:
begin
//pong received, ignore;
lFirstDataCode := lDataCode;
end;
end;
end
else
Break;
until bFIN;
//done?
if bFIN then
begin
if (lFirstDataCode in [wdcText, wdcBinary]) then
begin
//result
FMessageStream.Position := 0;
TIdStreamHelper.ReadBytes(FMessageStream, aBuffer);
Result := FMessageStream.Size;
aDataCode := lFirstDataCode
end
else if (lFirstDataCode in [wdcPing, wdcPong]) then
begin
//result
FMessageStream.Position := 0;
TIdStreamHelper.ReadBytes(FMessageStream, aBuffer);
SetLength(aBuffer, FMessageStream.Size);
//dummy data: there *must* be some data read otherwise connection is closed by Indy!
if Length(aBuffer) <= 0 then
begin
SetLength(aBuffer, 1);
aBuffer[0] := Ord(lFirstDataCode);
end;
Result := Length(aBuffer);
aDataCode := lFirstDataCode
end;
end;
end;
procedure TIdIOHandlerWebsocket.Lock;
begin
FLock.Enter;
end;
function TIdIOHandlerWebsocket.TryLock: Boolean;
begin
Result := FLock.TryEnter;
end;
procedure TIdIOHandlerWebsocket.Unlock;
begin
FLock.Leave;
end;
function TIdIOHandlerWebsocket.ReadFrame(out aFIN, aRSV1, aRSV2, aRSV3: boolean;
out aDataCode: TWSDataCode; out aData: TIdBytes): Integer;
var
iInputPos: NativeInt;
function _GetByte: Byte;
var
temp: TIdBytes;
begin
while FWSInputBuffer.Size <= iInputPos do
begin
//FWSInputBuffer.AsString;
InternalReadDataFromSource(temp);
FWSInputBuffer.Write(temp);
end;
//Self.ReadByte copies all data everytime (because the first byte must be removed) so we use index (much more efficient)
Result := FWSInputBuffer.PeekByte(iInputPos);
//FWSInputBuffer.AsString
inc(iInputPos);
end;
function _GetBytes(aCount: Integer): TIdBytes;
var
temp: TIdBytes;
begin
while FWSInputBuffer.Size < aCount do
begin
InternalReadDataFromSource(temp);
FWSInputBuffer.Write(temp);
end;
FWSInputBuffer.ExtractToBytes(Result, aCount);
end;
var
iByte: Byte;
i, iCode: NativeInt;
bHasMask: boolean;
iDataLength, iPos: Int64;
rMask: record
case Boolean of
True : (MaskAsBytes: array[0..3] of Byte);
False: (MaskAsInt : Int32);
end;
begin
iInputPos := 0;
SetLength(aData, 0);
aDataCode := wdcNone;
//wait + process data
iByte := _GetByte;
(* 0 1 2 3
0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 (nr)
7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0 (bit)
+-+-+-+-+-------+-+-------------+-------------------------------+
|F|R|R|R| opcode|M| Payload len | Extended payload length |
|I|S|S|S| (4) |A| (7) | (16/64) |
|N|V|V|V| |S| | (if payload len==126/127) |
| |1|2|3| |K| | |
+-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + *)
//FIN, RSV1, RSV2, RSV3: 1 bit each
aFIN := (iByte and (1 shl 7)) > 0;
aRSV1 := (iByte and (1 shl 6)) > 0;
aRSV2 := (iByte and (1 shl 5)) > 0;
aRSV3 := (iByte and (1 shl 4)) > 0;
//Opcode: 4 bits
iCode := (iByte and $0F); //clear 4 MSB's
case iCode of
C_FrameCode_Continuation: aDataCode := wdcContinuation;
C_FrameCode_Text: aDataCode := wdcText;
C_FrameCode_Binary: aDataCode := wdcBinary;
C_FrameCode_Close: aDataCode := wdcClose;
C_FrameCode_Ping: aDataCode := wdcPing;
C_FrameCode_Pong: aDataCode := wdcPong;
else
raise EIdException.CreateFmt('Unsupported data code: %d', [iCode]);
end;
//Mask: 1 bit
iByte := _GetByte;
bHasMask := (iByte and (1 shl 7)) > 0;
//Length (7 bits or 7+16 bits or 7+64 bits)
iDataLength := (iByte and $7F); //clear 1 MSB
//Extended payload length?
//If 126, the following 2 bytes interpreted as a 16-bit unsigned integer are the payload length
if (iDataLength = 126) then
begin
iByte := _GetByte;
iDataLength := (iByte shl 8); //8 MSB
iByte := _GetByte;
iDataLength := iDataLength + iByte;
end
//If 127, the following 8 bytes interpreted as a 64-bit unsigned integer (the most significant bit MUST be 0) are the payload length
else if (iDataLength = 127) then
begin
iDataLength := 0;
for i := 7 downto 0 do //read 8 bytes in reverse order
begin
iByte := _GetByte;
iDataLength := iDataLength +
(Int64(iByte) shl (8 * i)); //shift bits to left to recreate 64bit integer
end;
Assert(iDataLength > 0);
end;
//"All frames sent from client to server must have this bit set to 1"
if IsServerSide and not bHasMask then
raise EIdWebSocketHandleError.Create('No mask supplied: mask is required for clients when sending data to server')
else if not IsServerSide and bHasMask then
raise EIdWebSocketHandleError.Create('Mask supplied but mask is not allowed for servers when sending data to clients');
//Masking-key: 0 or 4 bytes
if bHasMask then
begin
rMask.MaskAsBytes[0] := _GetByte;
rMask.MaskAsBytes[1] := _GetByte;
rMask.MaskAsBytes[2] := _GetByte;
rMask.MaskAsBytes[3] := _GetByte;
end;
//Payload data: (x+y) bytes
FWSInputBuffer.Remove(iInputPos); //remove first couple of processed bytes (header)
//simple read?
if not bHasMask then
aData := _GetBytes(iDataLength)
else
//reverse mask
begin
aData := _GetBytes(iDataLength);
iPos := 0;
while iPos < iDataLength do
begin
aData[iPos] := aData[iPos] xor
rMask.MaskAsBytes[iPos mod 4]; //apply mask
inc(iPos);
end;
end;
Result := Length(aData);
end;
function TIdIOHandlerWebsocket.WriteData(aData: TIdBytes;
aType: TWSDataCode; aFIN, aRSV1, aRSV2, aRSV3: boolean): integer;
var
iByte: Byte;
i: NativeInt;
iDataLength, iPos: Int64;
rLength: Int64Rec;
rMask: record
case Boolean of
True : (MaskAsBytes: array[0..3] of Byte);
False: (MaskAsInt : Int32);
end;
strmData: TMemoryStream;
bData: TBytes;
begin
Result := 0;
Assert(Binding <> nil);
strmData := TMemoryStream.Create;
try
(* 0 1 2 3
0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 (nr)
7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0 (bit)
+-+-+-+-+-------+-+-------------+-------------------------------+
|F|R|R|R| opcode|M| Payload len | Extended payload length |
|I|S|S|S| (4) |A| (7) | (16/64) |
|N|V|V|V| |S| | (if payload len==126/127) |
| |1|2|3| |K| | |
+-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + *)
//FIN, RSV1, RSV2, RSV3: 1 bit each
if aFIN then iByte := (1 shl 7);
if aRSV1 then iByte := iByte + (1 shl 6);
if aRSV2 then iByte := iByte + (1 shl 5);
if aRSV3 then iByte := iByte + (1 shl 4);
//Opcode: 4 bits
case aType of
wdcContinuation : iByte := iByte + C_FrameCode_Continuation;
wdcText : iByte := iByte + C_FrameCode_Text;
wdcBinary : iByte := iByte + C_FrameCode_Binary;
wdcClose : iByte := iByte + C_FrameCode_Close;
wdcPing : iByte := iByte + C_FrameCode_Ping;
wdcPong : iByte := iByte + C_FrameCode_Pong;
else
raise EIdException.CreateFmt('Unsupported data code: %d', [Ord(aType)]);
end;
strmData.Write(iByte, SizeOf(iByte));
iByte := 0;
//Mask: 1 bit; Note: Clients must apply a mask
if not IsServerSide then iByte := (1 shl 7);
//Length: 7 bits or 7+16 bits or 7+64 bits
if Length(aData) < 126 then //7 bit, 128
iByte := iByte + Length(aData)
else if Length(aData) < 1 shl 16 then //16 bit, 65536
iByte := iByte + 126
else
iByte := iByte + 127;
strmData.Write(iByte, SizeOf(iByte));
//Extended payload length?
if Length(aData) >= 126 then
begin
//If 126, the following 2 bytes interpreted as a 16-bit unsigned integer are the payload length
if Length(aData) < 1 shl 16 then //16 bit, 65536
begin
rLength.Lo := Length(aData);
iByte := rLength.Bytes[1];
strmData.Write(iByte, SizeOf(iByte));
iByte := rLength.Bytes[0];
strmData.Write(iByte, SizeOf(iByte));
end
else
//If 127, the following 8 bytes interpreted as a 64-bit unsigned integer (the most significant bit MUST be 0) are the payload length
begin
rLength := Int64Rec(Int64(Length(aData)));
for i := 7 downto 0 do
begin
iByte := rLength.Bytes[i];
strmData.Write(iByte, SizeOf(iByte));
end;
end
end;
//Masking-key: 0 or 4 bytes; Note: Clients must apply a mask
if not IsServerSide then
begin
rMask.MaskAsInt := Random(MaxInt);
strmData.Write(rMask.MaskAsBytes[0], SizeOf(Byte));
strmData.Write(rMask.MaskAsBytes[1], SizeOf(Byte));
strmData.Write(rMask.MaskAsBytes[2], SizeOf(Byte));
strmData.Write(rMask.MaskAsBytes[3], SizeOf(Byte));
end;
//write header
strmData.Position := 0;
TIdStreamHelper.ReadBytes(strmData, bData);
Result := Binding.Send(bData);
//Mask? Note: Only clients must apply a mask
if IsServerSide then
begin
Result := Binding.Send(aData);
end
else
begin
iPos := 0;
iDataLength := Length(aData);
//in place masking
while iPos < iDataLength do
begin
iByte := aData[iPos] xor rMask.MaskAsBytes[iPos mod 4]; //apply mask
aData[iPos] := iByte;
inc(iPos);
end;
//send masked data
Result := Binding.Send(aData);
end;
finally
strmData.Free;
end;
end;
end.

11
IdServerBaseHandling.pas Normal file
View file

@ -0,0 +1,11 @@
unit IdServerBaseHandling;
interface
type
TIdServerBaseHandling = class
end;
implementation
end.

View file

@ -0,0 +1,46 @@
unit IdServerIOHandlerWebsocket;
interface
uses
Classes,
IdServerIOHandlerStack, IdIOHandlerStack, IdGlobal, IdIOHandler, IdYarn, IdThread, IdSocketHandle,
IdIOHandlerWebsocket;
type
TIdServerIOHandlerWebsocket = class(TIdServerIOHandlerStack)
protected
procedure InitComponent; override;
public
function Accept(ASocket: TIdSocketHandle; AListenerThread: TIdThread;
AYarn: TIdYarn): TIdIOHandler; override;
function MakeClientIOHandler(ATheThread:TIdYarn): TIdIOHandler; override;
end;
implementation
{ TIdServerIOHandlerStack_Websocket }
function TIdServerIOHandlerWebsocket.Accept(ASocket: TIdSocketHandle;
AListenerThread: TIdThread; AYarn: TIdYarn): TIdIOHandler;
begin
Result := inherited Accept(ASocket, AListenerThread, AYarn);
if Result <> nil then
(Result as TIdIOHandlerWebsocket).IsServerSide := True; //server must not mask, only client
end;
procedure TIdServerIOHandlerWebsocket.InitComponent;
begin
inherited InitComponent;
IOHandlerSocketClass := TIdIOHandlerWebsocket;
end;
function TIdServerIOHandlerWebsocket.MakeClientIOHandler(
ATheThread: TIdYarn): TIdIOHandler;
begin
Result := inherited MakeClientIOHandler(ATheThread);
if Result <> nil then
(Result as TIdIOHandlerWebsocket).IsServerSide := True; //server must not mask, only client
end;
end.

View file

@ -0,0 +1,194 @@
unit IdServerSocketIOHandling;
interface
uses
IdContext, IdCustomTCPServer,
//IdServerWebsocketContext,
Classes, Generics.Collections,
superobject, IdException, IdServerBaseHandling, IdSocketIOHandling;
type
TIdServerSocketIOHandling = class(TIdBaseSocketIOHandling)
protected
procedure ProcessHeatbeatRequest(const AContext: TSocketIOContext; const aText: string); override;
public
function SendToAll(const aMessage: string; const aCallback: TSocketIOMsgJSON = nil): Integer;
procedure SendTo (const aContext: TIdServerContext; const aMessage: string; const aCallback: TSocketIOMsgJSON = nil);
function EmitEventToAll(const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil): Integer;
procedure EmitEventTo (const aContext: TSocketIOContext;
const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil);overload;
procedure EmitEventTo (const aContext: TIdServerContext;
const aEventName: string; const aData: ISuperObject; const aCallback: TSocketIOMsgJSON = nil);overload;
end;
implementation
uses
SysUtils, StrUtils;
{ TIdServerSocketIOHandling }
procedure TIdServerSocketIOHandling.EmitEventTo(
const aContext: TSocketIOContext; const aEventName: string;
const aData: ISuperObject; const aCallback: TSocketIOMsgJSON);
var
jsonarray: string;
begin
if aContext.IsDisconnected then
raise EIdSocketIoUnhandledMessage.Create('socket.io connection closed!');
if aData.IsType(stArray) then
jsonarray := aData.AsString
else if aData.IsType(stString) then
jsonarray := '["' + aData.AsString + '"]'
else
jsonarray := '[' + aData.AsString + ']';
if not Assigned(aCallback) then
WriteSocketIOEvent(aContext, ''{no room}, aEventName, jsonarray, nil)
else
WriteSocketIOEventRef(aContext, ''{no room}, aEventName, jsonarray,
procedure(const aData: string)
begin
aCallback(aContext, SO(aData), nil);
end);
end;
procedure TIdServerSocketIOHandling.EmitEventTo(
const aContext: TIdServerContext; const aEventName: string;
const aData: ISuperObject; const aCallback: TSocketIOMsgJSON);
var
context: TSocketIOContext;
begin
Lock;
try
context := FConnections.Items[aContext];
EmitEventTo(context, aEventName, aData, aCallback);
finally
UnLock;
end;
end;
function TIdServerSocketIOHandling.EmitEventToAll(const aEventName: string; const aData: ISuperObject;
const aCallback: TSocketIOMsgJSON): Integer;
var
context: TSocketIOContext;
jsonarray: string;
begin
Result := 0;
if aData.IsType(stArray) then
jsonarray := aData.AsString
else if aData.IsType(stString) then
jsonarray := '["' + aData.AsString + '"]'
else
jsonarray := '[' + aData.AsString + ']';
Lock;
try
for context in FConnections.Values do
begin
if context.IsDisconnected then Continue;
if not Assigned(aCallback) then
WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil)
else
WriteSocketIOEventRef(context, ''{no room}, aEventName, jsonarray,
procedure(const aData: string)
begin
aCallback(context, SO(aData), nil);
end);
Inc(Result);
end;
for context in FConnectionsGUID.Values do
begin
if context.IsDisconnected then Continue;
if not Assigned(aCallback) then
WriteSocketIOEvent(context, ''{no room}, aEventName, jsonarray, nil)
else
WriteSocketIOEventRef(context, ''{no room}, aEventName, jsonarray,
procedure(const aData: string)
begin
aCallback(context, SO(aData), nil);
end);
Inc(Result);
end;
finally
UnLock;
end;
end;
procedure TIdServerSocketIOHandling.ProcessHeatbeatRequest(
const AContext: TSocketIOContext; const aText: string);
begin
inherited ProcessHeatbeatRequest(AContext, aText);
end;
procedure TIdServerSocketIOHandling.SendTo(const aContext: TIdServerContext;
const aMessage: string; const aCallback: TSocketIOMsgJSON);
var
context: TSocketIOContext;
begin
Lock;
try
context := FConnections.Items[aContext];
if context.IsDisconnected then
raise EIdSocketIoUnhandledMessage.Create('socket.io connection closed!');
if not Assigned(aCallback) then
WriteSocketIOMsg(context, ''{no room}, aMessage, nil)
else
WriteSocketIOMsg(context, ''{no room}, aMessage,
procedure(const aData: string)
begin
aCallback(context, SO(aData), nil);
end);
finally
UnLock;
end;
end;
function TIdServerSocketIOHandling.SendToAll(const aMessage: string;
const aCallback: TSocketIOMsgJSON): Integer;
var
context: TSocketIOContext;
begin
Result := 0;
Lock;
try
for context in FConnections.Values do
begin
if context.IsDisconnected then Continue;
if not Assigned(aCallback) then
WriteSocketIOMsg(context, ''{no room}, aMessage, nil)
else
WriteSocketIOMsg(context, ''{no room}, aMessage,
procedure(const aData: string)
begin
aCallback(context, SO(aData), nil);
end);
Inc(Result);
end;
for context in FConnectionsGUID.Values do
begin
if context.IsDisconnected then Continue;
if not Assigned(aCallback) then
WriteSocketIOMsg(context, ''{no room}, aMessage, nil)
else
WriteSocketIOMsg(context, ''{no room}, aMessage,
procedure(const aData: string)
begin
aCallback(context, SO(aData), nil);
end);
Inc(Result);
end;
finally
UnLock;
end;
end;
end.

View file

@ -0,0 +1,81 @@
unit IdServerWebsocketContext;
interface
uses
Classes,
IdCustomTCPServer, IdIOHandlerWebsocket,
IdServerBaseHandling, IdServerSocketIOHandling, IdContext;
type
TIdServerWSContext = class;
TWebsocketChannelRequest = procedure(const AContext: TIdServerWSContext; aType: TWSDataType; const strmRequest, strmResponse: TMemoryStream) of object;
TIdServerWSContext = class(TIdServerContext)
private
FWebSocketKey: string;
FWebSocketVersion: Integer;
FPath: string;
FWebSocketProtocol: string;
FResourceName: string;
FOrigin: string;
FQuery: string;
FHost: string;
FWebSocketExtensions: string;
FCookie: string;
//FSocketIOPingSend: Boolean;
FOnCustomChannelExecute: TWebsocketChannelRequest;
FSocketIO: TIdServerSocketIOHandling;
FOnDestroy: TIdContextEvent;
public
function IOHandler: TIdIOHandlerWebsocket;
public
function IsSocketIO: Boolean;
property SocketIO: TIdServerSocketIOHandling read FSocketIO write FSocketIO;
//property SocketIO: TIdServerBaseHandling read FSocketIO write FSocketIO;
property OnDestroy: TIdContextEvent read FOnDestroy write FOnDestroy;
public
destructor Destroy; override;
property Path : string read FPath write FPath;
property Query : string read FQuery write FQuery;
property ResourceName: string read FResourceName write FResourceName;
property Host : string read FHost write FHost;
property Origin : string read FOrigin write FOrigin;
property Cookie : string read FCookie write FCookie;
property WebSocketKey : string read FWebSocketKey write FWebSocketKey;
property WebSocketProtocol : string read FWebSocketProtocol write FWebSocketProtocol;
property WebSocketVersion : Integer read FWebSocketVersion write FWebSocketVersion;
property WebSocketExtensions: string read FWebSocketExtensions write FWebSocketExtensions;
public
property OnCustomChannelExecute: TWebsocketChannelRequest read FOnCustomChannelExecute write FOnCustomChannelExecute;
end;
implementation
uses
StrUtils;
{ TIdServerWSContext }
destructor TIdServerWSContext.Destroy;
begin
if Assigned(OnDestroy) then
OnDestroy(Self);
inherited;
end;
function TIdServerWSContext.IOHandler: TIdIOHandlerWebsocket;
begin
Result := Self.Connection.IOHandler as TIdIOHandlerWebsocket;
end;
function TIdServerWSContext.IsSocketIO: Boolean;
begin
//FDocument = '/socket.io/1/websocket/13412152'
Result := StartsText('/socket.io/1/websocket', FPath);
end;
end.

View file

@ -0,0 +1,317 @@
unit IdServerWebsocketHandling;
interface
uses
IdContext, IdCustomHTTPServer, IdHashSHA1,
IdServerSocketIOHandling, IdServerWebsocketContext,
Classes, IdServerBaseHandling, IdIOHandlerWebsocket;
type
TIdServerSocketIOHandling_Ext = class(TIdServerSocketIOHandling)
end;
TIdServerWebsocketHandling = class(TIdServerBaseHandling)
protected
class procedure DoWSExecute(AThread: TIdContext; aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual;
class procedure HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType;
aRequestStrm, aResponseStrm: TMemoryStream;
aSocketIOHandler: TIdServerSocketIOHandling_Ext);virtual;
public
class function ProcessServerCommandGet(AThread: TIdServerWSContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo): Boolean;
end;
implementation
uses
StrUtils, SysUtils, IdCustomTCPServer, IdCoderMIME;
{ TIdServerWebsocketHandling }
class procedure TIdServerWebsocketHandling.DoWSExecute(AThread: TIdContext; aSocketIOHandler: TIdServerSocketIOHandling_Ext);
var
strmRequest, strmResponse: TMemoryStream;
wscode: TWSDataCode;
wstype: TWSDataType;
context: TIdServerWSContext;
begin
context := nil;
try
context := AThread as TIdServerWSContext;
//todo: make seperate function + do it after first real write (not header!)
if context.IOHandler.BusyUpgrading then
begin
context.IOHandler.IsWebsocket := True;
context.IOHandler.BusyUpgrading := False;
end;
//initial connect
if context.IsSocketIO then
begin
Assert(aSocketIOHandler <> nil);
aSocketIOHandler.WriteConnect(context);
end;
//AThread.Connection.Socket.UseNagle := False;
while AThread.Connection.Connected do
begin
if (AThread.Connection.IOHandler.InputBuffer.Size > 0) or
AThread.Connection.IOHandler.Readable(5 * 1000) then //wait 5s, else ping the client(!)
begin
strmResponse := TMemoryStream.Create;
strmRequest := TMemoryStream.Create;
try
context := AThread as TIdServerWSContext;
strmRequest.Position := 0;
//first is the type: text or bin
wscode := TWSDataCode(context.IOHandler.ReadLongWord);
//then the length + data = stream
context.IOHandler.ReadStream(strmRequest);
strmRequest.Position := 0;
//ignore ping/pong messages
if wscode in [wdcPing, wdcPong] then
begin
if wscode = wdcPing then
context.IOHandler.WriteData(nil, wdcPong);
Continue;
end;
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)
end
else
context.IOHandler.WriteData(nil, wdcPing);
finally
strmRequest.Free;
strmResponse.Free;
end;
end
else
begin
//ping
if context.IsSocketIO then
begin
//context.SocketIOPingSend := True;
Assert(aSocketIOHandler <> nil);
aSocketIOHandler.WritePing(context);
end
else
context.IOHandler.WriteData(nil, wdcPing);
end;
end;
finally
if context.IsSocketIO then
begin
Assert(aSocketIOHandler <> nil);
aSocketIOHandler.WriteDisConnect(context);
end;
AThread.Data := nil;
end;
end;
class procedure TIdServerWebsocketHandling.HandleWSMessage(AContext: TIdServerWSContext; aType: TWSDataType;
aRequestStrm, aResponseStrm: TMemoryStream;
aSocketIOHandler: TIdServerSocketIOHandling_Ext);
begin
if AContext.IsSocketIO then
begin
aRequestStrm.Position := 0;
Assert(aSocketIOHandler <> nil);
aSocketIOHandler.ProcessSocketIORequest(AContext, aRequestStrm);
end
else if Assigned(AContext.OnCustomChannelExecute) then
AContext.OnCustomChannelExecute(AContext, aType, aRequestStrm, aResponseStrm);
end;
class function TIdServerWebsocketHandling.ProcessServerCommandGet(
AThread: TIdServerWSContext; ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo): Boolean;
var
sValue, squid: string;
context: TIdServerWSContext;
hash: TIdHashSHA1;
guid: TGUID;
begin
(* GET /chat HTTP/1.1
Host: server.example.com
Upgrade: websocket
Connection: Upgrade
Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==
Origin: http://example.com
Sec-WebSocket-Protocol: chat, superchat
Sec-WebSocket-Version: 13 *)
(* GET ws://echo.websocket.org/?encoding=text HTTP/1.1
Origin: http://websocket.org
Cookie: __utma=99as
Connection: Upgrade
Host: echo.websocket.org
Sec-WebSocket-Key: uRovscZjNol/umbTt5uKmw==
Upgrade: websocket
Sec-WebSocket-Version: 13 *)
//Connection: Upgrade
if not SameText('Upgrade', ARequestInfo.Connection) then
begin
//initiele ondersteuning voor socket.io
if SameText(ARequestInfo.document , '/socket.io/1/') then
begin
{
https://github.com/LearnBoost/socket.io-spec
The client will perform an initial HTTP POST request like the following
http://example.com/socket.io/1/
200: The handshake was successful.
The body of the response should contain the session id (sid) given to the client, followed by the heartbeat timeout, the connection closing timeout, and the list of supported transports separated by :
The absence of a heartbeat timeout ('') is interpreted as the server and client not expecting heartbeats.
For example 4d4f185e96a7b:15:10:websocket,xhr-polling.
}
AResponseInfo.ResponseNo := 200;
AResponseInfo.ResponseText := 'Socket.io connect OK';
CreateGUID(guid);
squid := GUIDToString(guid);
AResponseInfo.ContentText := squid +
':15:10:websocket,xhr-polling';
AResponseInfo.CloseConnection := False;
//(AThread.SocketIO as TIdServerSocketIOHandling_Ext).NewConnection(AThread);
(AThread.SocketIO as TIdServerSocketIOHandling_Ext).NewConnection(squid, AThread.Binding.PeerIP);
Result := True; //handled
end
//'/socket.io/1/xhr-polling/2129478544'
else if StartsText('/socket.io/1/xhr-polling/', ARequestInfo.document) then
begin
AResponseInfo.ContentStream := TMemoryStream.Create;
AResponseInfo.CloseConnection := False;
squid := Copy(ARequestInfo.Document, 1 + Length('/socket.io/1/xhr-polling/'), Length(ARequestInfo.document));
if ARequestInfo.CommandType = hcGET then
(AThread.SocketIO as TIdServerSocketIOHandling_Ext)
.ProcessSocketIO_XHR(squid, ARequestInfo.PostStream, AResponseInfo.ContentStream)
else if ARequestInfo.CommandType = hcPOST then
(AThread.SocketIO as TIdServerSocketIOHandling_Ext)
.ProcessSocketIO_XHR(squid, ARequestInfo.PostStream, nil); //no response expected with POST!
Result := True; //handled
end
else
Result := False; //NOT handled
end
else
begin
Result := True; //handled
context := AThread as TIdServerWSContext;
//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
// selected 16-byte value that has been base64-encoded"
if (sValue <> '') then
begin
if (Length(TIdDecoderMIME.DecodeString(sValue)) = 16) then
context.WebSocketKey := sValue
else
Abort; //invalid length
end
else
//important: key must exists, otherwise stop!
Abort;
(*
ws-URI = "ws:" "//" host [ ":" port ] path [ "?" query ]
wss-URI = "wss:" "//" host [ ":" port ] path [ "?" query ]
2. The method of the request MUST be GET, and the HTTP version MUST be at least 1.1.
For example, if the WebSocket URI is "ws://example.com/chat",
the first line sent should be "GET /chat HTTP/1.1".
3. The "Request-URI" part of the request MUST match the /resource
name/ defined in Section 3 (a relative URI) or be an absolute
http/https URI that, when parsed, has a /resource name/, /host/,
and /port/ that match the corresponding ws/wss URI.
*)
context.ResourceName := ARequestInfo.Document;
if ARequestInfo.UnparsedParams <> '' then
context.ResourceName := context.ResourceName + '?' +
ARequestInfo.UnparsedParams;
//seperate parts
context.Path := ARequestInfo.Document;
context.Query := ARequestInfo.UnparsedParams;
//Host: server.example.com
context.Host := ARequestInfo.RawHeaders.Values['host'];
//Origin: http://example.com
context.Origin := ARequestInfo.RawHeaders.Values['origin'];
//Cookie: __utma=99as
context.Cookie := ARequestInfo.RawHeaders.Values['cookie'];
//Sec-WebSocket-Version: 13
//"The value of this header field MUST be 13"
sValue := ARequestInfo.RawHeaders.Values['sec-websocket-version'];
if (sValue <> '') then
begin
context.WebSocketVersion := StrToIntDef(sValue, 0);
if context.WebSocketVersion < 13 then
Abort; //must be at least 13
end
else
Abort; //must exist
context.WebSocketProtocol := ARequestInfo.RawHeaders.Values['sec-websocket-protocol'];
context.WebSocketExtensions := ARequestInfo.RawHeaders.Values['sec-websocket-extensions'];
//Response
(* HTTP/1.1 101 Switching Protocols
Upgrade: websocket
Connection: Upgrade
Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo= *)
AResponseInfo.ResponseNo := 101;
AResponseInfo.ResponseText := 'Switching Protocols';
AResponseInfo.CloseConnection := False;
//Connection: Upgrade
AResponseInfo.Connection := 'Upgrade';
//Upgrade: websocket
AResponseInfo.CustomHeaders.Values['Upgrade'] := 'websocket';
//Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=
sValue := Trim(context.WebSocketKey) + //... "minus any leading and trailing whitespace"
'258EAFA5-E914-47DA-95CA-C5AB0DC85B11'; //special GUID
hash := TIdHashSHA1.Create;
try
sValue := TIdEncoderMIME.EncodeBytes( //Base64
hash.HashString(sValue) ); //SHA1
finally
hash.Free;
end;
AResponseInfo.CustomHeaders.Values['Sec-WebSocket-Accept'] := sValue;
//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
//send response back
context.IOHandler.InputBuffer.Clear;
context.IOHandler.BusyUpgrading := True;
AResponseInfo.WriteHeader;
//handle all WS communication in seperate loop
DoWSExecute(AThread, (context.SocketIO as TIdServerSocketIOHandling_Ext) );
end;
end;
end.

1239
IdSocketIOHandling.pas Normal file

File diff suppressed because it is too large Load diff

156
IdWebsocketServer.pas Normal file
View file

@ -0,0 +1,156 @@
unit IdWebsocketServer;
interface
uses
IdServerWebsocketHandling, IdServerSocketIOHandling, IdServerWebsocketContext,
IdHTTPServer, IdContext, IdCustomHTTPServer, Classes, IdIOHandlerWebsocket;
type
TWebsocketMessageText = procedure(const AContext: TIdServerWSContext; const aText: string) of object;
TWebsocketMessageBin = procedure(const AContext: TIdServerWSContext; const aData: TStream) of object;
TIdWebsocketServer = class(TIdHTTPServer)
private
FSocketIO: TIdServerSocketIOHandling_Ext;
FOnMessageText: TWebsocketMessageText;
FOnMessageBin: TWebsocketMessageBin;
function GetSocketIO: TIdServerSocketIOHandling;
protected
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);
public
procedure AfterConstruction; override;
destructor Destroy; override;
procedure SendMessageToAll(const aBinStream: TStream);overload;
procedure SendMessageToAll(const aText: string);overload;
property OnMessageText: TWebsocketMessageText read FOnMessageText write FOnMessageText;
property OnMessageBin : TWebsocketMessageBin read FOnMessageBin write FOnMessageBin;
property SocketIO: TIdServerSocketIOHandling read GetSocketIO;
end;
implementation
uses
IdServerIOHandlerWebsocket, IdStreamVCL, IdGlobal, Windows;
{ TIdWebsocketServer }
procedure TIdWebsocketServer.AfterConstruction;
begin
inherited;
FSocketIO := TIdServerSocketIOHandling_Ext.Create;
ContextClass := TIdServerWSContext;
if IOHandler = nil then
IOHandler := TIdServerIOHandlerWebsocket.Create(Self);
end;
procedure TIdWebsocketServer.ContextCreated(AContext: TIdContext);
begin
inherited ContextCreated(AContext);
(AContext as TIdServerWSContext).OnCustomChannelExecute := Self.WebsocketChannelRequest;
end;
procedure TIdWebsocketServer.ContextDisconnected(AContext: TIdContext);
begin
FSocketIO.FreeConnection(AContext);
inherited;
end;
destructor TIdWebsocketServer.Destroy;
begin
inherited;
FSocketIO.Free;
end;
procedure TIdWebsocketServer.DoCommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
(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.GetSocketIO: TIdServerSocketIOHandling;
begin
Result := FSocketIO;
end;
procedure TIdWebsocketServer.SendMessageToAll(const aText: string);
var
l: TList;
ctx: TIdServerWSContext;
i: Integer;
begin
l := Self.Contexts.LockList;
try
for i := 0 to l.Count - 1 do
begin
ctx := TIdServerWSContext(l.Items[i]);
Assert(ctx is TIdServerWSContext);
if ctx.IOHandler.IsWebsocket and
not ctx.IsSocketIO
then
ctx.IOHandler.Write(aText);
end;
finally
Self.Contexts.UnlockList;
end;
end;
procedure TIdWebsocketServer.WebsocketChannelRequest(
const AContext: TIdServerWSContext; aType: TWSDataType; const aStrmRequest,
aStrmResponse: TMemoryStream);
var s: string;
begin
if aType = wdtText then
begin
with TStreamReader.Create(aStrmRequest) do
begin
s := ReadToEnd;
Free;
end;
if Assigned(OnMessageText) then
OnMessageText(AContext, s)
end
else if Assigned(OnMessageBin) then
OnMessageBin(AContext, aStrmRequest)
end;
procedure TIdWebsocketServer.SendMessageToAll(const aBinStream: TStream);
var
l: TList;
ctx: TIdServerWSContext;
i: Integer;
bytes: TIdBytes;
begin
l := Self.Contexts.LockList;
try
TIdStreamHelperVCL.ReadBytes(aBinStream, bytes);
for i := 0 to l.Count - 1 do
begin
ctx := TIdServerWSContext(l.Items[i]);
Assert(ctx is TIdServerWSContext);
if ctx.IOHandler.IsWebsocket and
not ctx.IsSocketIO
then
ctx.IOHandler.Write(bytes);
end;
finally
Self.Contexts.UnlockList;
end;
end;
end.