UTF-8 support for message.

packages/fcl-web/src/websocket/fpwebsocket.pp

@@ -236,6 +236,7 @@ type
     FFinalFrame: Boolean;
     FRSV: Byte;
     FPayload : TWSFramePayload;
+    FReason: WORD;
   protected
     function Read(aTransport: IWSTransport): boolean;
     function GetAsBytes : TBytes; virtual;
@@ -250,6 +251,7 @@ type
     property FinalFrame: Boolean read FFinalFrame write FFinalFrame;
     property Payload : TWSFramePayload Read FPayload Write FPayLoad;
     property FrameType: TFrameType read FFrameType;
+    property Reason: WORD read FReason;
     Property AsBytes : TBytes Read GetAsBytes;
   end;
   TWSFrameClass = Class of TWSFrame;
@@ -319,6 +321,7 @@ type
     function GetHandshakeCompleted: Boolean; virtual; abstract;
     Function GetTransport : IWSTransport; virtual; abstract;
     property Owner : TComponent Read FOwner;
+    function IsValidUTF8(aValue: TBytes): boolean;
   Public
     Type
       TConnectionIDAllocator = Procedure(out aID : String) of object;
@@ -672,7 +675,7 @@ end;
 function TWSMessage.GetAsString: UTF8String;
 
 begin
-  Result:=TEncoding.UTF8.GetAnsiString(Payload);
+  Result:=TEncoding.UTF8.GetString(Payload);
 end;
 
 function TWSMessage.GetAsUnicodeString: UnicodeString;
@@ -918,8 +921,12 @@ end;
 
 constructor TWSFrame.Create(aType: TFrameType; aIsFinal: Boolean; APayload: TBytes; aMask: Integer=0);
 
+var
+  closeData: TBytes;
+
 begin
   Create(aType,aIsFinal,aMask);
+
   FPayload.Data := APayload;
   if Assigned(aPayload) then
     FPayload.DataLength := Cardinal(Length(aPayload));
@@ -928,6 +935,7 @@ end;
 constructor TWSFrame.Create(aType: TFrameType; aIsFinal : Boolean = True; aMask: Integer=0);
 
 begin
+  FReason:=CLOSE_NORMAL_CLOSURE;
   FPayload:=Default(TWSFramePayload);
   FPayload.MaskKey:=aMask;
   FPayload.Masked:=aMask<>0;
@@ -942,7 +950,7 @@ Var
   Data : TBytes;
 
 begin
-  Data:=TEncoding.UTF8.GetAnsiBytes(AMessage);
+  Data:=TEncoding.UTF8.GetBytes(AMessage);
   Create(ftText,True,Data,aMask);
 end;
 
@@ -1140,7 +1148,7 @@ begin
   end;
 end;
 
-procedure TWSConnection.SetHandShakeRequest(aRequest: TWSHandshakeRequest);
+procedure TWSConnection.SetHandShakeRequest(aRequest: TWSHandShakeRequest);
 begin
   FreeAndNil(FHandshakeRequest);
   FHandShakeRequest:=aRequest;
@@ -1224,18 +1232,18 @@ begin
   ftBinary,
   ftText :
     begin
-    if Assigned(FOnMessageReceived) then
+      if Assigned(FOnMessageReceived) then
       begin
-      Msg:=Default(TWSMessage);
-      Msg.IsText:=(aInitialType=ftText);
-      if aFrame.FrameType=ftBinary then
-        Msg.Sequences:=[fsFirst]
-      else
-        Msg.Sequences:=[fsContinuation];
-      if aFrame.FinalFrame then
-        Msg.Sequences:=Msg.Sequences+[fsLast];
-      Msg.PayLoad:=aMessageContent;
-      FOnMessageReceived(Self, Msg);
+        Msg:=Default(TWSMessage);
+        Msg.IsText:=(aInitialType=ftText);
+        if aFrame.FrameType=ftBinary then
+          Msg.Sequences:=[fsFirst]
+        else
+          Msg.Sequences:=[fsContinuation];
+        if aFrame.FinalFrame then
+          Msg.Sequences:=Msg.Sequences+[fsLast];
+        Msg.PayLoad:=aMessageContent;
+        FOnMessageReceived(Self, Msg);
       end;
     end;
   ftContinuation: ; // Cannot happen normally
@@ -1253,22 +1261,25 @@ function TWSConnection.HandleIncoming(aFrame: TWSFrame) : Boolean;
        FCloseState:=csClosed;
    end;
 
+   procedure ProtocolError(aCode: Word);
+   begin
+     Close('', aCode);
+     UpdateCloseState;
+     Result:=false;
+   end;
+
 begin
-  Result:=True;
+  Result:=true;
   // check Reserved bits
   if aFrame.Reserved<>0 then
   begin
-    Close('', CLOSE_PROTOCOL_ERROR);
-    UpdateCloseState;
-    Result:=false;
+    ProtocolError(CLOSE_PROTOCOL_ERROR);
     Exit;
   end;
   // check Reserved opcode
   if aFrame.FrameType = ftFutureOpcodes then
   begin
-    Close('', CLOSE_PROTOCOL_ERROR);
-    UpdateCloseState;
-    Result:=false;
+    ProtocolError(CLOSE_PROTOCOL_ERROR);
     Exit;
   end;
   { If control frame it must be complete }
@@ -1277,63 +1288,177 @@ begin
       (aFrame.FrameType=ftClose))
      and (not aFrame.FinalFrame) then
   begin
-    Close('', CLOSE_PROTOCOL_ERROR);
-    UpdateCloseState;
-    Result:=false;
+    ProtocolError(CLOSE_PROTOCOL_ERROR);
     Exit;
   end;
+  //
+
   // here we handle payload.
-  if aFrame.FrameType in [ftBinary,ftText] then
-  begin
-    FInitialOpcode:=aFrame.FrameType;
-    FMessageContent:=aFrame.Payload.Data;
-  end;
+//  if aFrame.FrameType in [ftBinary,ftText] then
+//  begin
+//    FInitialOpcode:=aFrame.FrameType;
+//    FMessageContent:=aFrame.Payload.Data;
+//  end;
+
   // Special handling
   Case aFrame.FrameType of
     ftContinuation:
       begin
+        if FInitialOpcode=ftContinuation then
+        begin
+          ProtocolError(CLOSE_PROTOCOL_ERROR);
+          Exit;
+        end;
+
         FMessageContent.Append(aFrame.Payload.Data);
         if aFrame.FinalFrame then
-          DispatchEvent(FInitialOpcode,aFrame,FMessageContent);
+        begin
+          if FInitialOpcode = ftText then
+            if IsValidUTF8(FMessageContent) then
+              DispatchEvent(FInitialOpcode,aFrame,FMessageContent)
+            else
+              ProtocolError(CLOSE_INVALID_FRAME_PAYLOAD_DATA)
+          else
+            DispatchEvent(FInitialOpcode,aFrame,FMessageContent);
+          // reset initial opcode
+          FInitialOpcode:=ftContinuation;
+        end;
       end;
 
     ftPing:
       begin
         if aFrame.Payload.DataLength > 125 then
-          Close('', CLOSE_PROTOCOL_ERROR)
+          ProtocolError(CLOSE_PROTOCOL_ERROR)
         else
-          if not (woPongExplicit in Options) then
-          begin
-            Send(ftPong,aFrame.Payload.Data);
-            DispatchEvent(ftPing,aFrame,aFrame.Payload.Data);
-          end;
+        if not (woPongExplicit in Options) then
+        begin
+          Send(ftPong,aFrame.Payload.Data);
+          DispatchEvent(ftPing,aFrame,aFrame.Payload.Data);
+        end;
      end;
    ftClose:
      begin
-     // If our side sent the initial close, this is the reply, and we must disconnect (Result=false).
-     Result:=FCloseState=csNone;
-     if Result then
-     begin
-       if not (woCloseExplicit in Options) then
+       // If our side sent the initial close, this is the reply, and we must disconnect (Result=false).
+       Result:=FCloseState=csNone;
+       if Result then
        begin
-         Close('', CLOSE_NORMAL_CLOSURE); // Will update state
-         Result:=False; // We can disconnect.
-         DispatchEvent(ftClose,aFrame,aFrame.Payload.Data);
+         if (Length(aFrame.Payload.Data)=1) or (Length(aFrame.Payload.Data)>125) then
+         begin
+           ProtocolError(CLOSE_PROTOCOL_ERROR);
+           exit;
+         end;
+
+         if not (woCloseExplicit in Options) then
+         begin
+           DispatchEvent(ftClose,aFrame,aFrame.Payload.Data);
+           Close('', CLOSE_NORMAL_CLOSURE); // Will update state
+           UpdateCloseState;
+           Result:=False; // We can disconnect.
+         end
+         else
+           UpdateCloseState
        end
        else
-         UpdateCloseState
-     end
-     else
-       UpdateCloseState;
+         UpdateCloseState;
      end;
    ftBinary,ftText:
-     if aFrame.FinalFrame then
-       DispatchEvent(FInitialOpcode,aFrame,aFrame.Payload.Data);
+     begin
+       if FInitialOpcode in [ftText, ftBinary] then
+       begin
+         ProtocolError(CLOSE_PROTOCOL_ERROR);
+         Exit;
+       end;
+       FInitialOpcode:=aFrame.FrameType;
+       FMessageContent:=aFrame.Payload.Data;
+       if aFrame.FinalFrame then
+       begin
+         if aFrame.FrameType = ftText then
+           if IsValidUTF8(aFrame.Payload.Data) then
+             DispatchEvent(FInitialOpcode,aFrame,aFrame.Payload.Data)
+           else
+             ProtocolError(CLOSE_INVALID_FRAME_PAYLOAD_DATA)
+         else
+           DispatchEvent(FInitialOpcode,aFrame,aFrame.Payload.Data);
+
+         FInitialOpcode:=ftContinuation;
+       end;
+     end;
   else
     ; // avoid Compiler warning
   End;
 end;
 
+function TWSConnection.IsValidUTF8(aValue: TBytes): boolean;
+var
+  i, len, n, j: integer;
+  c: ^byte;
+begin
+  Result := true;
+  len := length(aValue);
+  if len = 0 then
+    exit;
+  Result := False;
+  i := 0;
+  c := @AValue[0];
+  while i < len do
+  begin
+    if (c^ >= $00) and (c^ <= $7f) then
+      n := 0
+    else if (c^ >= $c2) and (c^ <= $df) then
+      n := 1
+    else if (c^ = $e0) then
+      n := 2
+    else if (c^ >= $e1) and (c^ <= $ec) then
+      n := 2
+    else if (c^ = $ed) then
+      n := 2
+    else if (c^ >= $ee) and (c^ <= $ef) then
+      n := 2
+    else if (c^ = $f0) then
+      n := 3
+    else if (c^ >= $f1) and (c^ <= $f3) then
+      n := 3
+    else if (c^ = $f4) then
+      n := 3
+    else
+      exit;
+
+    j := 0;
+    Inc(i);
+
+    while j < n do
+    begin
+      if i >= len then
+        exit;
+      case c^ of
+        $c2..$df, $e1..$ec, $ee..$ef, $f1..$f3:
+          if not (((c + 1)^ >= $80) and ((c + 1)^ <= $bf)) then
+            exit;
+        $e0:
+          if not (((c + 1)^ >= $a0) and ((c + 1)^ <= $bf)) then
+            exit;
+        $ed:
+          if not (((c + 1)^ >= $80) and ((c + 1)^ <= $9f)) then
+            exit;
+        $f0:
+          if not (((c + 1)^ >= $90) and ((c + 1)^ <= $bf)) then
+            exit;
+        $f4:
+          if not (((c + 1)^ >= $80) and ((c + 1)^ <= $8f)) then
+            exit;
+        $80..$bf:
+          if not (((c + 1)^ >= $80) and ((c + 1)^ <= $bf)) then
+            exit;
+      end;
+      Inc(c);
+      Inc(i);
+      Inc(j);
+    end;
+    Inc(c);
+  end;
+  Result := True;
+end;
+
 function TWSConnection.FrameClass: TWSFrameClass;
 
 begin
@@ -1376,6 +1501,7 @@ var
   aData: TBytes;
   aSize: Integer;
 begin
+  aData := [];
   // first two bytes is reason of close RFC 6455 section-5.5.1
   aData := TEncoding.UTF8.GetAnsiBytes(aMessage);
   aSize := Length(aData);