first checkin

IdIOHandlerWebsocket.pas

@@ -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.

IdServerBaseHandling.pas

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

IdServerIOHandlerWebsocket.pas

@@ -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.

IdServerSocketIOHandling.pas

@@ -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.

IdServerWebsocketContext.pas

@@ -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.

IdServerWebsocketHandling.pas

@@ -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.

IdWebsocketServer.pas

@@ -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.