├── demo ├── testApp.ico ├── testApp.res ├── testApp.lpr ├── main.lfm ├── testApp.lpi ├── main.pas └── testApp.lps ├── .gitignore ├── sywebsocket.pas ├── README.md ├── sywebsocket.lpk └── src ├── syhttpheader.pas ├── sywebsocketcommon.pas ├── sywebsocketmessage.pas ├── sywebsocketclient.pas ├── sywebsocketpackmanager.pas ├── sywebsocketserver.pas ├── sywebsocketframe.pas └── syconnectedclient.pas /demo/testApp.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seryal/sywebsocket/HEAD/demo/testApp.ico -------------------------------------------------------------------------------- /demo/testApp.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seryal/sywebsocket/HEAD/demo/testApp.res -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /backup 2 | /lib 3 | /*.dbg 4 | /*.exe 5 | /demo/backup 6 | /demo/lib/x86_64-win64 7 | /demo/testApp.dbg 8 | /demo/testApp.exe 9 | /src/backup 10 | -------------------------------------------------------------------------------- /demo/testApp.lpr: -------------------------------------------------------------------------------- 1 | program testApp; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX}{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF}{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, main; 11 | 12 | {$R *.res} 13 | 14 | begin 15 | RequireDerivedFormResource := True; 16 | Application.Scaled := True; 17 | Application.Initialize; 18 | Application.CreateForm(TForm1, Form1); 19 | Application.Run; 20 | end. 21 | 22 | -------------------------------------------------------------------------------- /sywebsocket.pas: -------------------------------------------------------------------------------- 1 | { This file was automatically created by Lazarus. Do not edit! 2 | This source is only used to compile and install the package. 3 | } 4 | 5 | unit syWebSocket; 6 | 7 | {$warn 5023 off : no warning about unused units} 8 | interface 9 | 10 | uses 11 | syconnectedclient, syhttpheader, sywebsocketframe, sywebsocketmessage, 12 | sywebsocketpackmanager, syWebSocketServer, sywebsocketclient, 13 | sywebsocketcommon, LazarusPackageIntf; 14 | 15 | implementation 16 | 17 | procedure Register; 18 | begin 19 | end; 20 | 21 | initialization 22 | RegisterPackage('syWebSocket', @Register); 23 | end. 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sywebsocket 2 | Websocket Server and Client for Lazarus Applications. 3 | 4 | ## Requirements: 5 | https://github.com/svn2github/Ararat-Synapse/tree/master/trunk 6 | 7 | 8 | 9 | ## For Windows: 10 | **TESTED** 11 | 12 | ## For Ubuntu: 13 | **TESTED** 14 | 15 | ## Example 16 | ```pascal 17 | var 18 | FWebSocket: TsyWebSocketServer; 19 | 20 | begin 21 | FWebSocket := TsyWebSocketServer.Create(8081); 22 | FWebSocket.OnTextMessage := @OnTextMessage; 23 | FWebSocket.Start; 24 | end; 25 | 26 | procedure OnTextMessage(Sender: TObject); 27 | var 28 | val: TMessageRecord; 29 | begin 30 | if not Assigned(FWebSocket) then 31 | exit; 32 | while FWebSocket.MessageQueue.TotalItemsPushed <> FWebSocket.MessageQueue.TotalItemsPopped do 33 | begin 34 | FWebSocket.MessageQueue.PopItemTimeout(val, 100); 35 | if val.Opcode = optText then 36 | begin 37 | Memo1.Lines.Add(IntToStr(TsyConnectedClient(val.Sender).Tag) + ': ' + val.Message); 38 | end; 39 | end; 40 | end; 41 | ``` 42 | 43 | Page for test https://www.websocket.org/echo.html 44 | 45 | 46 | ## RFC 6455 47 | [Server test result](http://syware.ru/html_result/) 48 | 49 | Autobahn WebSocket Testsuite v0.8.0/v0.10.9. results. (https://github.com/crossbario/autobahn-testsuite) 50 | 51 | 52 | -------------------------------------------------------------------------------- /sywebsocket.lpk: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | <_ExternHelp Items="Count"/> 69 | 70 | 71 | 72 | -------------------------------------------------------------------------------- /src/syhttpheader.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : sy WebSocket Server | 3 | |==============================================================================| 4 | | Copyright (c)2020, Yuri Serebrennikov | 5 | | All rights reserved. | 6 | | | 7 | | Redistribution and use in source and binary forms, with or without | 8 | | modification, are permitted provided that the following conditions are met: | 9 | | | 10 | | Redistributions of source code must retain the above copyright notice, this | 11 | | list of conditions and the following disclaimer. | 12 | | | 13 | | Redistributions in binary form must reproduce the above copyright notice, | 14 | | this list of conditions and the following disclaimer in the documentation | 15 | | and/or other materials provided with the distribution. | 16 | | | 17 | | Neither the name of Yuri serebrennikov nor the names of its contributors may | 18 | | be used to endorse or promote products derived from this software without | 19 | | specific prior written permission. | 20 | | | 21 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 22 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 23 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 24 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 25 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 26 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 27 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 28 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 29 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 30 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 31 | | DAMAGE. | 32 | |==============================================================================| 33 | | The Initial Developer of the Original Code is Yuri Serebrennikov | 34 | | All Rights Reserved. | 35 | |==============================================================================| 36 | | (Found at URL: https://github.com/seryal/sywebsocket/) | 37 | |==============================================================================} 38 | unit syhttpheader; 39 | 40 | {$mode objfpc}{$H+} 41 | 42 | interface 43 | 44 | uses 45 | Classes, SysUtils, synautil; 46 | 47 | type 48 | 49 | { THTTPRecord } 50 | 51 | THTTPRecord = object 52 | Method: string; 53 | Uri: string; 54 | Protocol: string; 55 | procedure Parse(AValue: string); 56 | end; 57 | 58 | implementation 59 | 60 | { THTTPRecord } 61 | 62 | procedure THTTPRecord.Parse(AValue: string); 63 | var 64 | s: string; 65 | begin 66 | s := AValue; 67 | if s = '' then 68 | exit; 69 | method := fetch(s, ' '); 70 | if method = '' then 71 | Exit; 72 | uri := fetch(s, ' '); 73 | if uri = '' then 74 | Exit; 75 | protocol := fetch(s, ' '); 76 | end; 77 | 78 | end. 79 | -------------------------------------------------------------------------------- /src/sywebsocketcommon.pas: -------------------------------------------------------------------------------- 1 | unit sywebsocketcommon; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, synautil, lazCollections; 9 | 10 | type 11 | TOpcodeType = ( 12 | optContinue = 0, 13 | optText = 1, 14 | optBinary = 2, 15 | { 3..7 - reserved } 16 | optCloseConnect = 8, 17 | optPing = 9, 18 | optPong = 10); 19 | 20 | TMessageRecord = record 21 | Opcode: TOpcodeType; 22 | Reason: integer; 23 | Message: string; 24 | BinaryData: TBytes; 25 | Sender: pointer; 26 | end; 27 | 28 | TMessageQueue = specialize TLazThreadedQueue; 29 | 30 | function IsWebSocketConnect(AHeader: TStringList): boolean; 31 | function IsValidUTF8(AValue: PChar; ALen: integer): boolean; 32 | 33 | 34 | implementation 35 | 36 | function IsWebSocketConnect(AHeader: TStringList): boolean; 37 | var 38 | s: string; 39 | headerKey, headerValue: string; 40 | begin 41 | Result := False; 42 | for s in AHeader do 43 | begin 44 | headerValue := s; 45 | headerKey := Fetch(headerValue, ':'); 46 | if (LowerCase(headerKey) = 'upgrade') and (LowerCase(headerValue) = 'websocket') then 47 | begin 48 | Result := True; 49 | Exit; 50 | end; 51 | end; 52 | end; 53 | 54 | /////////////////////////////////////////////////// 55 | { 56 | +----------+----------+----------+----------+ 57 | | $00..$7F | | | | 58 | | $C2..$DF | $80..$BF | | | 59 | | $E0 | $A0..$BF | $80..$BF | | 60 | | $E1..$EC | $80..$BF | $80..$BF | | 61 | | $ED | $80..$9F | $80..$BF | | 62 | | $EE..$EF | $80..$BF | $80..$BF | | 63 | | $F0 | $90..$BF | $80..$BF | $80..$BF | 64 | | $F1..$F3 | $80..$BF | $80..$BF | $80..$BF | 65 | | $F4 | $80..$8F | $80..$BF | $80..$BF | 66 | +----------+----------+----------+----------+ 67 | } 68 | /////////////////////////////////////////////////// 69 | function IsValidUTF8(AValue: PChar; ALen: integer): boolean; 70 | var 71 | i, len, n, j: integer; 72 | c: ^byte; 73 | begin 74 | Result := False; 75 | len := ALen; 76 | i := 0; 77 | c := @AValue[0]; 78 | while i < len do 79 | begin 80 | if (c^ >= $00) and (c^ <= $7f) then 81 | n := 0 82 | else if (c^ >= $c2) and (c^ <= $df) then 83 | n := 1 84 | else if (c^ = $e0) then 85 | n := 2 86 | else if (c^ >= $e1) and (c^ <= $ec) then 87 | n := 2 88 | else if (c^ = $ed) then 89 | n := 2 90 | else if (c^ >= $ee) and (c^ <= $ef) then 91 | n := 2 92 | else if (c^ = $f0) then 93 | n := 3 94 | else if (c^ >= $f1) and (c^ <= $f3) then 95 | n := 3 96 | else if (c^ = $f4) then 97 | n := 3 98 | else 99 | exit; 100 | 101 | j := 0; 102 | Inc(i); 103 | 104 | while j < n do 105 | begin 106 | if i >= len then 107 | exit; 108 | case c^ of 109 | $c2..$df, $e1..$ec, $ee..$ef, $f1..$f3: 110 | if not (((c + 1)^ >= $80) and ((c + 1)^ <= $bf)) then 111 | exit; 112 | $e0: 113 | if not (((c + 1)^ >= $a0) and ((c + 1)^ <= $bf)) then 114 | exit; 115 | $ed: 116 | if not (((c + 1)^ >= $80) and ((c + 1)^ <= $9f)) then 117 | exit; 118 | $f0: 119 | if not (((c + 1)^ >= $90) and ((c + 1)^ <= $bf)) then 120 | exit; 121 | $f4: 122 | if not (((c + 1)^ >= $80) and ((c + 1)^ <= $8f)) then 123 | exit; 124 | $80..$bf: 125 | if not (((c + 1)^ >= $80) and ((c + 1)^ <= $bf)) then 126 | exit; 127 | end; 128 | Inc(c); 129 | Inc(i); 130 | Inc(j); 131 | end; 132 | Inc(c); 133 | end; 134 | Result := True; 135 | end; 136 | 137 | end. 138 | 139 | -------------------------------------------------------------------------------- /demo/main.lfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 605 3 | Height = 534 4 | Top = 230 5 | Width = 663 6 | Caption = 'Form1' 7 | ClientHeight = 534 8 | ClientWidth = 663 9 | OnClose = FormClose 10 | object GroupBox1: TGroupBox 11 | Left = 8 12 | Height = 272 13 | Top = 8 14 | Width = 641 15 | Caption = 'Server' 16 | ClientHeight = 252 17 | ClientWidth = 637 18 | TabOrder = 0 19 | object btnStart: TButton 20 | Left = 8 21 | Height = 25 22 | Top = 56 23 | Width = 75 24 | Caption = 'Start' 25 | OnClick = btnStartClick 26 | TabOrder = 0 27 | end 28 | object btnStop: TButton 29 | Left = 88 30 | Height = 25 31 | Top = 56 32 | Width = 75 33 | Caption = 'Stop' 34 | Enabled = False 35 | OnClick = btnStopClick 36 | TabOrder = 1 37 | end 38 | object Button1: TButton 39 | Left = 8 40 | Height = 25 41 | Top = 184 42 | Width = 75 43 | Caption = 'Send' 44 | OnClick = Button1Click 45 | TabOrder = 2 46 | end 47 | object Edit1: TEdit 48 | Left = 8 49 | Height = 23 50 | Top = 144 51 | Width = 288 52 | TabOrder = 3 53 | Text = 'My message for all clients.' 54 | end 55 | object Edit2: TEdit 56 | Left = 8 57 | Height = 23 58 | Top = 24 59 | Width = 80 60 | OnChange = Edit2Change 61 | TabOrder = 4 62 | Text = '8089' 63 | end 64 | object Label1: TLabel 65 | Cursor = crHandPoint 66 | Left = 99 67 | Height = 15 68 | Top = 32 69 | Width = 160 70 | Caption = 'Url for test ws://localhost:8089' 71 | Font.Color = clBlue 72 | Font.Style = [fsUnderline] 73 | ParentFont = False 74 | OnClick = Label1Click 75 | end 76 | object Memo1: TMemo 77 | Left = 320 78 | Height = 210 79 | Top = 16 80 | Width = 304 81 | TabOrder = 5 82 | end 83 | object Label2: TLabel 84 | Left = 8 85 | Height = 15 86 | Top = 0 87 | Width = 22 88 | Caption = 'Port' 89 | end 90 | end 91 | object GroupBox2: TGroupBox 92 | Left = 8 93 | Height = 240 94 | Top = 288 95 | Width = 641 96 | Caption = 'Client' 97 | ClientHeight = 220 98 | ClientWidth = 637 99 | TabOrder = 1 100 | object btnClientStart: TButton 101 | Left = 8 102 | Height = 25 103 | Top = 56 104 | Width = 75 105 | Caption = 'Start' 106 | OnClick = btnClientStartClick 107 | TabOrder = 0 108 | end 109 | object Memo2: TMemo 110 | Left = 320 111 | Height = 208 112 | Top = 0 113 | Width = 302 114 | TabOrder = 1 115 | end 116 | object btnClientStop: TButton 117 | Left = 88 118 | Height = 25 119 | Top = 56 120 | Width = 75 121 | Caption = 'Stop' 122 | OnClick = btnClientStopClick 123 | TabOrder = 2 124 | end 125 | object Edit3: TEdit 126 | Left = 8 127 | Height = 23 128 | Top = 24 129 | Width = 200 130 | TabOrder = 3 131 | Text = 'ws://localhost:8089' 132 | end 133 | object Label3: TLabel 134 | Left = 8 135 | Height = 15 136 | Top = 0 137 | Width = 25 138 | Caption = 'Host' 139 | end 140 | object Edit4: TEdit 141 | Left = 224 142 | Height = 23 143 | Top = 24 144 | Width = 80 145 | Enabled = False 146 | TabOrder = 4 147 | Text = '8089' 148 | end 149 | object Edit5: TEdit 150 | Left = 8 151 | Height = 23 152 | Top = 104 153 | Width = 288 154 | TabOrder = 5 155 | Text = 'QaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaW' 156 | end 157 | object Button2: TButton 158 | Left = 8 159 | Height = 25 160 | Top = 144 161 | Width = 75 162 | Caption = 'Send' 163 | OnClick = Button2Click 164 | TabOrder = 6 165 | end 166 | end 167 | end 168 | -------------------------------------------------------------------------------- /demo/testApp.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | <Scaled Value="True"/> 13 | <ResourceType Value="res"/> 14 | <UseXPManifest Value="True"/> 15 | <XPManifest> 16 | <DpiAware Value="True"/> 17 | </XPManifest> 18 | <Icon Value="0"/> 19 | </General> 20 | <BuildModes Count="3"> 21 | <Item1 Name="Default" Default="True"/> 22 | <Item2 Name="Debug"> 23 | <CompilerOptions> 24 | <Version Value="11"/> 25 | <PathDelim Value="\"/> 26 | <Target> 27 | <Filename Value="testApp"/> 28 | </Target> 29 | <SearchPaths> 30 | <IncludeFiles Value="$(ProjOutDir)"/> 31 | <OtherUnitFiles Value="..\src"/> 32 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 33 | </SearchPaths> 34 | <Parsing> 35 | <SyntaxOptions> 36 | <IncludeAssertionCode Value="True"/> 37 | </SyntaxOptions> 38 | </Parsing> 39 | <CodeGeneration> 40 | <Checks> 41 | <IOChecks Value="True"/> 42 | <RangeChecks Value="True"/> 43 | <OverflowChecks Value="True"/> 44 | <StackChecks Value="True"/> 45 | </Checks> 46 | <VerifyObjMethodCallValidity Value="True"/> 47 | </CodeGeneration> 48 | <Linking> 49 | <Debugging> 50 | <DebugInfoType Value="dsDwarf2Set"/> 51 | <UseHeaptrc Value="True"/> 52 | <TrashVariables Value="True"/> 53 | <UseExternalDbgSyms Value="True"/> 54 | </Debugging> 55 | <Options> 56 | <Win32> 57 | <GraphicApplication Value="True"/> 58 | </Win32> 59 | </Options> 60 | </Linking> 61 | <Other> 62 | <CustomOptions Value="-dDEBUG"/> 63 | <OtherDefines Count="1"> 64 | <Define0 Value="DEBUG"/> 65 | </OtherDefines> 66 | </Other> 67 | </CompilerOptions> 68 | </Item2> 69 | <Item3 Name="Release"> 70 | <CompilerOptions> 71 | <Version Value="11"/> 72 | <PathDelim Value="\"/> 73 | <Target> 74 | <Filename Value="testApp"/> 75 | </Target> 76 | <SearchPaths> 77 | <IncludeFiles Value="$(ProjOutDir)"/> 78 | <OtherUnitFiles Value="..\src"/> 79 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 80 | </SearchPaths> 81 | <CodeGeneration> 82 | <SmartLinkUnit Value="True"/> 83 | <Optimizations> 84 | <OptimizationLevel Value="3"/> 85 | </Optimizations> 86 | </CodeGeneration> 87 | <Linking> 88 | <Debugging> 89 | <GenerateDebugInfo Value="False"/> 90 | </Debugging> 91 | <LinkSmart Value="True"/> 92 | <Options> 93 | <Win32> 94 | <GraphicApplication Value="True"/> 95 | </Win32> 96 | </Options> 97 | </Linking> 98 | <Other> 99 | <OtherDefines Count="1"> 100 | <Define0 Value="DEBUG"/> 101 | </OtherDefines> 102 | </Other> 103 | </CompilerOptions> 104 | </Item3> 105 | </BuildModes> 106 | <PublishOptions> 107 | <Version Value="2"/> 108 | <UseFileFilters Value="True"/> 109 | </PublishOptions> 110 | <RunParams> 111 | <FormatVersion Value="2"/> 112 | </RunParams> 113 | <RequiredPackages Count="2"> 114 | <Item1> 115 | <PackageName Value="syWebSocket"/> 116 | </Item1> 117 | <Item2> 118 | <PackageName Value="LCL"/> 119 | </Item2> 120 | </RequiredPackages> 121 | <Units Count="2"> 122 | <Unit0> 123 | <Filename Value="testApp.lpr"/> 124 | <IsPartOfProject Value="True"/> 125 | </Unit0> 126 | <Unit1> 127 | <Filename Value="main.pas"/> 128 | <IsPartOfProject Value="True"/> 129 | <ComponentName Value="Form1"/> 130 | <HasResources Value="True"/> 131 | <ResourceBaseClass Value="Form"/> 132 | </Unit1> 133 | </Units> 134 | </ProjectOptions> 135 | <CompilerOptions> 136 | <Version Value="11"/> 137 | <PathDelim Value="\"/> 138 | <Target> 139 | <Filename Value="testApp"/> 140 | </Target> 141 | <SearchPaths> 142 | <IncludeFiles Value="$(ProjOutDir)"/> 143 | <OtherUnitFiles Value="..\src"/> 144 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 145 | </SearchPaths> 146 | <Linking> 147 | <Options> 148 | <Win32> 149 | <GraphicApplication Value="True"/> 150 | </Win32> 151 | </Options> 152 | </Linking> 153 | </CompilerOptions> 154 | <Debugging> 155 | <Exceptions Count="3"> 156 | <Item1> 157 | <Name Value="EAbort"/> 158 | </Item1> 159 | <Item2> 160 | <Name Value="ECodetoolError"/> 161 | </Item2> 162 | <Item3> 163 | <Name Value="EFOpenError"/> 164 | </Item3> 165 | </Exceptions> 166 | </Debugging> 167 | </CONFIG> 168 | -------------------------------------------------------------------------------- /src/sywebsocketmessage.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : sy WebSocket Server | 3 | |==============================================================================| 4 | | Copyright (c)2020, Yuri Serebrennikov | 5 | | All rights reserved. | 6 | | | 7 | | Redistribution and use in source and binary forms, with or without | 8 | | modification, are permitted provided that the following conditions are met: | 9 | | | 10 | | Redistributions of source code must retain the above copyright notice, this | 11 | | list of conditions and the following disclaimer. | 12 | | | 13 | | Redistributions in binary form must reproduce the above copyright notice, | 14 | | this list of conditions and the following disclaimer in the documentation | 15 | | and/or other materials provided with the distribution. | 16 | | | 17 | | Neither the name of Yuri serebrennikov nor the names of its contributors may | 18 | | be used to endorse or promote products derived from this software without | 19 | | specific prior written permission. | 20 | | | 21 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 22 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 23 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 24 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 25 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 26 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 27 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 28 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 29 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 30 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 31 | | DAMAGE. | 32 | |==============================================================================| 33 | | The Initial Developer of the Original Code is Yuri Serebrennikov | 34 | | All Rights Reserved. | 35 | |==============================================================================| 36 | | (Found at URL: https://github.com/seryal/sywebsocket/) | 37 | |==============================================================================} 38 | unit sywebsocketmessage; 39 | 40 | {$mode objfpc}{$H+} 41 | 42 | interface 43 | 44 | uses 45 | Classes, SysUtils, sywebsocketframe, sywebsocketcommon; 46 | 47 | type 48 | 49 | { TsyWebSocketMessage } 50 | 51 | TsyWebSocketMessage = class 52 | private 53 | FData: TMemoryStream; 54 | FReason: word; 55 | FIsReady: boolean; 56 | FMessageType: TOpcodeType; 57 | function GetBinData: TBytes; 58 | function GetMessageStr: string; 59 | function GetPayloadLen: integer; 60 | public 61 | function AddData(AFrame: TsyBaseWebsocketFrame): boolean; 62 | constructor Create; 63 | destructor Destroy; override; 64 | property IsReady: boolean read FIsReady write FisReady; 65 | property Opcode: TOpcodeType read FMessageType write FMessageType; 66 | property MessageStr: string read GetMessageStr; 67 | property BinData: TBytes read GetBinData; 68 | property MessageType: TOpcodeType read FMessageType; 69 | property PayloadLen: integer read GetPayloadLen; 70 | end; 71 | 72 | 73 | implementation 74 | 75 | { TsyWebSocketMessage } 76 | 77 | function TsyWebSocketMessage.GetBinData: TBytes; 78 | var 79 | len: integer; 80 | begin 81 | len := FData.Size; 82 | SetLength(Result, len); 83 | if len > 0 then 84 | begin 85 | FData.Position := 0; 86 | FData.ReadBuffer(Result[0], len); 87 | // SetLength(Result, len); 88 | end; 89 | end; 90 | 91 | function TsyWebSocketMessage.GetMessageStr: string; 92 | var 93 | ustr: UTF8String; 94 | len: integer; 95 | begin 96 | Result := ''; 97 | len := FData.Size; 98 | if len > 0 then 99 | begin 100 | SetLength(ustr, len); 101 | FData.Position := 0; 102 | FData.ReadBuffer(ustr[1], len); 103 | Result := ustr; 104 | end; 105 | end; 106 | 107 | function TsyWebSocketMessage.GetPayloadLen: integer; 108 | begin 109 | Result := FData.Size; 110 | end; 111 | 112 | function TsyWebSocketMessage.AddData(AFrame: TsyBaseWebsocketFrame): boolean; 113 | begin 114 | Result := True; 115 | FReason := AFrame.Reason; 116 | 117 | { if (not FIsReady) and (AFrame.OpCode <> optContinue) then // only optContinue if we wait next frame; 118 | begin 119 | Result := False; 120 | exit; 121 | end;} 122 | 123 | case AFrame.OpCode of 124 | optContinue: 125 | begin 126 | if FIsReady then // if first frame continue then HALT 127 | begin 128 | Result := False; 129 | exit; 130 | end; 131 | FIsReady := AFrame.Fin; 132 | if AFrame.PayloadLen > 0 then 133 | FData.Write(AFrame.Binary[0], AFrame.PayloadLen); 134 | end; 135 | optText, optBinary: 136 | begin 137 | if not FIsReady then 138 | begin 139 | Result := False; 140 | exit; 141 | end; 142 | FIsReady := AFrame.Fin; 143 | FMessageType := AFrame.OpCode; 144 | FData.Clear; 145 | if AFrame.PayloadLen > 0 then 146 | FData.Write(AFrame.Binary[0], AFrame.PayloadLen); 147 | end; 148 | end; 149 | end; 150 | 151 | constructor TsyWebSocketMessage.Create; 152 | begin 153 | FIsReady := True; 154 | FData := TMemoryStream.Create; 155 | end; 156 | 157 | destructor TsyWebSocketMessage.Destroy; 158 | begin 159 | FreeAndNil(FData); 160 | inherited Destroy; 161 | end; 162 | 163 | end. 164 | -------------------------------------------------------------------------------- /demo/main.pas: -------------------------------------------------------------------------------- 1 | unit main; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls, 9 | syWebSocketServer, syconnectedclient, sywebsocketframe, sywebsocketclient, lclintf, sywebsocketcommon; 10 | 11 | type 12 | 13 | { TForm1 } 14 | 15 | TForm1 = class(TForm) 16 | btnStart: TButton; 17 | btnStop: TButton; 18 | Button1: TButton; 19 | btnClientStart: TButton; 20 | btnClientStop: TButton; 21 | Button2: TButton; 22 | Edit1: TEdit; 23 | Edit2: TEdit; 24 | Edit3: TEdit; 25 | Edit4: TEdit; 26 | Edit5: TEdit; 27 | GroupBox1: TGroupBox; 28 | GroupBox2: TGroupBox; 29 | Label1: TLabel; 30 | Label2: TLabel; 31 | Label3: TLabel; 32 | Memo1: TMemo; 33 | Memo2: TMemo; 34 | procedure btnClientStopClick(Sender: TObject); 35 | procedure btnStartClick(Sender: TObject); 36 | procedure btnStopClick(Sender: TObject); 37 | procedure Button1Click(Sender: TObject); 38 | procedure btnClientStartClick(Sender: TObject); 39 | procedure Button2Click(Sender: TObject); 40 | procedure Edit2Change(Sender: TObject); 41 | procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 42 | procedure Label1Click(Sender: TObject); 43 | private 44 | FWebSocket: TsyWebSocketServer; 45 | FwsClient: TsyWebsocketClient; 46 | procedure OnClientConected(Sender: TObject); 47 | procedure OnClientDisconnected(Sender: TObject); 48 | procedure OnClientMessage(Sender: TObject); 49 | procedure OnClientTerminate(Sender: TObject); 50 | procedure OnMessage(Sender: TObject); 51 | public 52 | 53 | end; 54 | 55 | var 56 | Form1: TForm1; 57 | 58 | implementation 59 | 60 | {$R *.lfm} 61 | 62 | { TForm1 } 63 | 64 | procedure TForm1.btnStartClick(Sender: TObject); 65 | begin 66 | FWebSocket := TsyWebSocketServer.Create(StrToInt(Edit2.Text)); 67 | // Event notifying that there are messages in the queue 68 | FWebSocket.OnMessage := @OnMessage; 69 | FWebSocket.OnClientConnected := @OnClientConected; 70 | FWebSocket.OnClientDisconnected := @OnClientDisconnected; 71 | FWebSocket.Start; 72 | btnStart.Enabled := False; 73 | btnStop.Enabled := True; 74 | end; 75 | 76 | procedure TForm1.btnClientStopClick(Sender: TObject); 77 | begin 78 | if assigned(FwsClient) then 79 | FwsClient.TerminateThread; 80 | FwsClient := nil; 81 | btnClientStop.Enabled := False; 82 | btnClientStart.Enabled := True; 83 | 84 | end; 85 | 86 | procedure TForm1.btnStopClick(Sender: TObject); 87 | begin 88 | if Assigned(FWebSocket) then 89 | begin 90 | FWebSocket.TerminateThread; 91 | FreeAndNil(FWebSocket); 92 | end; 93 | btnStop.Enabled := False; 94 | btnStart.Enabled := True; 95 | end; 96 | 97 | procedure TForm1.Button1Click(Sender: TObject); 98 | var 99 | ClientList: TClientList; 100 | Client: TsyConnectedClient; 101 | begin 102 | if not Assigned(FWebSocket) then 103 | exit; 104 | ClientList := FWebSocket.LockedClientList.LockList; 105 | 106 | try 107 | for client in ClientList do 108 | begin 109 | Client.SendMessageFrame(Edit1.Text); 110 | end; 111 | 112 | finally 113 | FWebSocket.LockedClientList.UnlockList; 114 | end; 115 | end; 116 | 117 | procedure TForm1.btnClientStartClick(Sender: TObject); 118 | begin 119 | // FwsClient := TsyWebsocketClient.Create(edit3.Text, StrToInt64Def(Edit4.Text, 8080)); 120 | FwsClient := TsyWebsocketClient.Create(edit3.Text); 121 | FwsClient.OnMessage := @OnClientMessage; 122 | FwsClient.OnTerminate := @OnClientTerminate; 123 | FwsClient.Start; 124 | btnClientStart.Enabled := False; 125 | btnClientStop.Enabled := True; 126 | end; 127 | 128 | procedure TForm1.Button2Click(Sender: TObject); 129 | begin 130 | FwsClient.SendMessage(Edit5.Text); 131 | end; 132 | 133 | 134 | 135 | procedure TForm1.Edit2Change(Sender: TObject); 136 | begin 137 | Label1.Caption := 'Url for test ws://localhost:' + Edit2.Text; 138 | end; 139 | 140 | procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction); 141 | begin 142 | btnClientStopClick(Sender); 143 | btnStopClick(Sender); 144 | end; 145 | 146 | procedure TForm1.Label1Click(Sender: TObject); 147 | begin 148 | OpenURL('https://www.websocket.org/echo.html'); 149 | end; 150 | 151 | 152 | procedure TForm1.OnMessage(Sender: TObject); 153 | var 154 | val: TMessageRecord; 155 | begin 156 | 157 | if not Assigned(FWebSocket) then 158 | exit; 159 | if FWebSocket.MessageQueue.TotalItemsPushed = FWebSocket.MessageQueue.TotalItemsPopped then 160 | exit; 161 | while FWebSocket.MessageQueue.TotalItemsPushed <> FWebSocket.MessageQueue.TotalItemsPopped do 162 | begin 163 | FWebSocket.MessageQueue.PopItemTimeout(val, 100); 164 | 165 | case val.Opcode of 166 | optText: 167 | begin 168 | TsyConnectedClient(val.Sender).SendMessageFrame(val.Message); 169 | // Memo1.Lines.Add(IntToStr(TsyConnectedClient(val.Sender).Tag) + ': Message Len ' + IntToStr(length(val.Message))); 170 | Memo1.Lines.Add(IntToStr(TsyConnectedClient(val.Sender).Tag) + ': ' + val.Message); 171 | end; 172 | optCloseConnect: 173 | begin 174 | Memo1.Lines.Add(IntToStr(TsyConnectedClient(val.Sender).Tag) + ': Close Len ' + 175 | IntToStr(length(val.Message))); 176 | end; 177 | optPing: 178 | begin 179 | Memo1.Lines.Add(IntToStr(TsyConnectedClient(val.Sender).Tag) + ': Ping Len ' + 180 | IntToStr(length(val.Message))); 181 | end; 182 | optBinary: 183 | begin 184 | TsyConnectedClient(val.Sender).SendBinaryFrame(val.BinaryData); 185 | Memo1.Lines.Add(IntToStr(TsyConnectedClient(val.Sender).Tag) + ': Bin Length ' + 186 | IntToStr(length(val.BinaryData))); 187 | end; 188 | end; 189 | end; 190 | end; 191 | 192 | procedure TForm1.OnClientDisconnected(Sender: TObject); 193 | begin 194 | Memo1.Lines.Add('Client Disconnected: ' + IntToStr(TsyConnectedClient(Sender).Tag)); 195 | end; 196 | 197 | procedure TForm1.OnClientMessage(Sender: TObject); 198 | var 199 | val: TMessageRecord; 200 | 201 | begin 202 | if not Assigned(FwsClient) then 203 | exit; 204 | while FwsClient.MessageQueue.TotalItemsPushed <> FwsClient.MessageQueue.TotalItemsPopped do 205 | begin 206 | FwsClient.MessageQueue.PopItem(val); 207 | Memo2.Lines.Add(val.Message); 208 | 209 | end; 210 | end; 211 | 212 | procedure TForm1.OnClientTerminate(Sender: TObject); 213 | begin 214 | Memo2.Lines.Add('Terminated'); 215 | btnClientStopClick(self); 216 | end; 217 | 218 | procedure TForm1.OnClientConected(Sender: TObject); 219 | begin 220 | Memo1.Lines.Add('Client Connected: ' + IntToStr(TsyConnectedClient(Sender).Tag)); 221 | TsyConnectedClient(Sender).SendMessageFrame('Hello'); 222 | end; 223 | 224 | 225 | 226 | 227 | end. 228 | 229 | // test url 230 | // wss://demo.piesocket.com/v3/channel_1?api_key=oCdCMcMPQpbvNjUIzqtvF1d2X2okWpDQj4AwARJuAgtjhzKxVEjQU6IdCjwm¬ify_self 231 | -------------------------------------------------------------------------------- /src/sywebsocketclient.pas: -------------------------------------------------------------------------------- 1 | unit sywebsocketclient; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, blcksock, base64, sywebsocketcommon, sywebsocketpackmanager, 9 | sywebsocketframe, synsock, synautil, ssl_openssl; 10 | 11 | type 12 | 13 | { TsyWebsocketClient } 14 | 15 | TsyWebsocketClient = class(TThread) 16 | private 17 | FUrl: string; 18 | FHost: string; 19 | FPath: string; 20 | FProt: string; 21 | FOnConnected: TNotifyEvent; 22 | FOnMessage: TNotifyEvent; 23 | FPort: string; 24 | FCritSection: TRTLCriticalSection; 25 | FTerminateEvent: PRTLEvent; 26 | FSock: TTCPBlockSocket; 27 | FSecKey: string; 28 | FWebSocket: boolean; 29 | FWebsocketFrame: TsyWebsockPackManager; 30 | FMessageQueue: TMessageQueue; 31 | procedure Execute; override; 32 | procedure OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); 33 | procedure SendHandshake; 34 | procedure MessageNotify; 35 | procedure DoConnected; 36 | public 37 | constructor Create(AHost: string; APort: word); 38 | constructor Create(AUrl: string); 39 | destructor Destroy; override; 40 | property OnMessage: TNotifyEvent read FOnMessage write FOnMessage; 41 | property OnConnected: TNotifyEvent read FOnConnected write FOnConnected; 42 | property MessageQueue: TMessageQueue read FMessageQueue; 43 | procedure SendMessage(AValue: string); 44 | procedure TerminateThread; 45 | end; 46 | 47 | implementation 48 | 49 | { TsyWebsocketClient } 50 | 51 | procedure TsyWebsocketClient.Execute; 52 | var 53 | str: string; 54 | Header: TStringList; 55 | DataLen: integer; 56 | DataBuffer: TBytes; 57 | RcvLen: integer; 58 | RcvFrame: TMemoryStream; 59 | wsFrame: TsyBaseWebsocketFrame; 60 | MsgRec: TMessageRecord; 61 | error: integer; 62 | begin 63 | // ParseURL(); 64 | // connect to server 65 | FSock.OnStatus := @OnStatus; 66 | // fhost := 'google.com'; 67 | FSock.Connect(FHost, FPort); 68 | error := FSock.SocksLastError; 69 | if FProt = 'wss' then 70 | FSock.SSLDoConnect; 71 | error := FSock.LastError; 72 | str := FSock.GetErrorDescEx; 73 | // send HTTP handshake - i'm websocket client 74 | SendHandshake; 75 | Header := TStringList.Create; 76 | try 77 | // get answer from server 78 | repeat 79 | str := FSock.RecvString(5000); 80 | Header.Add(str); 81 | until str = ''; 82 | str := Header.Text; 83 | // websocket server or not? 84 | FWebSocket := IsWebSocketConnect(Header); 85 | // if not websoket server then exit 86 | if not FWebSocket then 87 | exit; 88 | 89 | // if websocket server then check Secure-Key 90 | // if not CheckSecureKey(Header) then 91 | // exit; 92 | 93 | 94 | 95 | finally 96 | FreeAndNil(Header); 97 | end; 98 | 99 | 100 | str := ''; 101 | // start websocket protocol 102 | try 103 | Queue(@DoConnected); 104 | 105 | FWebsocketFrame := TsyWebsockPackManager.Create; 106 | while not Terminated do 107 | begin 108 | if FSock.CanRead(1000) then 109 | begin 110 | DataLen := FSock.WaitingData; 111 | if DataLen = 0 then 112 | exit; 113 | SetLength(DataBuffer, DataLen); 114 | // str := FSock.RecvString(5000); 115 | RcvLen := FSock.RecvBuffer(@DataBuffer[0], DataLen); 116 | //if RcvLen <> DataLen then // need raise exception 117 | // Exit; 118 | FWebsocketFrame.InsertData(DataBuffer, RcvLen); 119 | 120 | while FWebsocketFrame.Count > 0 do 121 | begin 122 | RcvFrame := FWebsocketFrame.Pop; 123 | wsFrame := TsyBaseWebsocketFrame.Create; 124 | try 125 | wsFrame.Frame := RcvFrame; 126 | MsgRec.Opcode := wsFrame.OpCode; 127 | MsgRec.Reason := wsFrame.Reason; 128 | MsgRec.Sender := self; 129 | MsgRec.BinaryData := wsFrame.Binary; 130 | MsgRec.Message := wsFrame.MessageStr; 131 | FMessageQueue.PushItem(MsgRec); 132 | Synchronize(@MessageNotify); 133 | finally 134 | FreeAndNil(wsFrame); 135 | end; 136 | 137 | end; 138 | 139 | end; 140 | //RTLeventWaitFor(FTerminateEvent, 1000); 141 | end; 142 | 143 | finally 144 | FreeAndNil(FWebsocketFrame); 145 | end; 146 | TerminateThread; 147 | end; 148 | 149 | procedure TsyWebsocketClient.OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); 150 | var 151 | str: string; 152 | begin 153 | case Reason of 154 | HR_Error: 155 | TerminateThread; 156 | end; 157 | end; 158 | 159 | procedure TsyWebsocketClient.SendHandshake; 160 | var 161 | str: string; 162 | key: string; 163 | begin 164 | Randomize; 165 | str := 'GET ' + FUrl + ' HTTP/1.1' + CRLF; 166 | str := str + 'Host: ' + FHost + ':' + FPort + CRLF; 167 | str := str + 'Connection: Upgrade' + CRLF; 168 | str := str + 'Upgrade: websocket' + CRLF; 169 | str := str + 'Pragma: no-cache' + CRLF; 170 | str := str + 'Cache-Control: no-cache' + CRLF; 171 | FSecKey := EncodeStringBase64(IntToHex(Random($7FFFFFFFFFFFFFFF), 16)); 172 | str := str + 'Sec-WebSocket-Key: ' + FSecKey + CRLF; 173 | str := str + 'Origin: ' + 'http://syware.ru' + CRLF; 174 | //str := str + 'Sec-WebSocket-Protocol: chat, superchat' + CRLF; 175 | str := str + 'Sec-WebSocket-Extensions: permessage-deflate; client_max_window_bits' + CRLF; 176 | str := str + 'Sec-WebSocket-Version: 13' + CRLF; 177 | FSock.SendString(str + CRLF); 178 | end; 179 | 180 | procedure TsyWebsocketClient.MessageNotify; 181 | begin 182 | if not Terminated then 183 | if Assigned(OnMessage) then 184 | OnMessage(Self); 185 | end; 186 | 187 | procedure TsyWebsocketClient.DoConnected; 188 | begin 189 | if Assigned(OnConnected) then 190 | OnConnected(Self); 191 | end; 192 | 193 | constructor TsyWebsocketClient.Create(AHost: string; APort: word); 194 | begin 195 | FHost := AHost; 196 | FPort := IntToStr(APort); 197 | InitCriticalSection(FCritSection); 198 | FMessageQueue := TMessageQueue.Create; 199 | FSock := TTCPBlockSocket.Create; 200 | FTerminateEvent := RTLEventCreate; 201 | FreeOnTerminate := True; 202 | inherited Create(True); 203 | end; 204 | 205 | constructor TsyWebsocketClient.Create(AUrl: string); 206 | var 207 | host: string; 208 | port: string; 209 | prot: string; 210 | user: string; 211 | pass: string; 212 | path: string; 213 | para: string; 214 | begin 215 | FUrl := AUrl; 216 | ParseURL(AUrl, prot, User, pass, host, port, path, para); 217 | FProt := prot; 218 | FPath := path; 219 | if port = EmptyStr then 220 | begin 221 | if prot = 'wss' then 222 | port := '443'; 223 | if prot = 'ws' then 224 | port := '80'; 225 | end; 226 | 227 | FHost := host; 228 | FPort := port; 229 | InitCriticalSection(FCritSection); 230 | FMessageQueue := TMessageQueue.Create; 231 | FSock := TTCPBlockSocket.Create; 232 | FTerminateEvent := RTLEventCreate; 233 | FreeOnTerminate := True; 234 | inherited Create(True); 235 | 236 | end; 237 | 238 | destructor TsyWebsocketClient.Destroy; 239 | begin 240 | RTLeventdestroy(FTerminateEvent); 241 | FreeAndNil(FMessageQueue); 242 | FreeAndNil(FSock); 243 | DoneCriticalsection(FCritSection); 244 | inherited Destroy; 245 | end; 246 | 247 | procedure TsyWebsocketClient.SendMessage(AValue: string); 248 | var 249 | WFrame: TsyBaseWebsocketFrame; 250 | begin 251 | EnterCriticalsection(FCritSection); 252 | try 253 | WFrame := TsyBaseWebsocketFrame.Create; 254 | try 255 | WFrame.Opcode := optText; 256 | WFrame.Mask := True; 257 | WFrame.MessageStr := AValue; 258 | if FSock.CanWrite(1000) then 259 | FSock.SendBuffer(WFrame.Frame.Memory, WFrame.Frame.Size); 260 | finally 261 | FreeAndNil(WFrame); 262 | end; 263 | finally 264 | LeaveCriticalsection(FCritSection); 265 | end; 266 | end; 267 | 268 | procedure TsyWebsocketClient.TerminateThread; 269 | begin 270 | if Terminated then 271 | exit; 272 | FSock.AbortSocket; 273 | Terminate; 274 | RTLeventSetEvent(FTerminateEvent); 275 | end; 276 | 277 | end. 278 | -------------------------------------------------------------------------------- /src/sywebsocketpackmanager.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : sy WebSocket Server | 3 | |==============================================================================| 4 | | Copyright (c)2020, Yuri Serebrennikov | 5 | | All rights reserved. | 6 | | | 7 | | Redistribution and use in source and binary forms, with or without | 8 | | modification, are permitted provided that the following conditions are met: | 9 | | | 10 | | Redistributions of source code must retain the above copyright notice, this | 11 | | list of conditions and the following disclaimer. | 12 | | | 13 | | Redistributions in binary form must reproduce the above copyright notice, | 14 | | this list of conditions and the following disclaimer in the documentation | 15 | | and/or other materials provided with the distribution. | 16 | | | 17 | | Neither the name of Yuri serebrennikov nor the names of its contributors may | 18 | | be used to endorse or promote products derived from this software without | 19 | | specific prior written permission. | 20 | | | 21 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 22 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 23 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 24 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 25 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 26 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 27 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 28 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 29 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 30 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 31 | | DAMAGE. | 32 | |==============================================================================| 33 | | The Initial Developer of the Original Code is Yuri Serebrennikov | 34 | | All Rights Reserved. | 35 | |==============================================================================| 36 | | (Found at URL: https://github.com/seryal/sywebsocket/) | 37 | |==============================================================================} 38 | unit sywebsocketpackmanager; 39 | 40 | {$mode objfpc}{$H+} 41 | 42 | interface 43 | 44 | uses 45 | Classes, SysUtils, contnrs, Generics.Collections; 46 | 47 | const 48 | MIN_WEBSOCKETSIZE = 2; 49 | 50 | type 51 | PBytes = ^TBytes; 52 | 53 | TFrameQueue = class(specialize TQueue<TMemoryStream>); 54 | { TsyWebsockPackManager } 55 | 56 | TsyWebsockPackManager = class 57 | private 58 | // размер ожидаемого пакета 59 | FFrameSize: QWord; 60 | // Буфер фрейма. 61 | FWebsocketBuffer: TMemoryStream; 62 | // Список полученых фреймов 63 | FFrameQueue: TFrameQueue; 64 | 65 | function GetCount: integer; 66 | function GetPop: TMemoryStream; 67 | function GetWebsocketFrameSize(ABuffer: Pointer; ASize: integer): QWord; 68 | function InsertWebsocketFrame(ABuffer: TBytes; Position: integer; Size: integer): integer; 69 | public 70 | constructor Create; 71 | destructor Destroy; override; 72 | procedure InsertData(AData: TBytes; ALen: integer); 73 | property Count: integer read GetCount; 74 | property Pop: TMemoryStream read GetPop; 75 | end; 76 | 77 | implementation 78 | 79 | { TsyWebsockPackManager } 80 | 81 | function TsyWebsockPackManager.GetWebsocketFrameSize(ABuffer: Pointer; ASize: integer): QWord; 82 | var 83 | HeaderArr: array [0..9] of byte; 84 | HeaderCount: integer; 85 | _mask: boolean; 86 | Payload7: byte; 87 | PayLoad16: word; 88 | Payload64: QWord; 89 | PayloadLen: Qword; 90 | begin 91 | Result := 0; 92 | HeaderCount := 2; 93 | if ASize < MIN_WEBSOCKETSIZE then 94 | exit; 95 | move(ABuffer^, HeaderArr[0], ASize); 96 | _Mask := (HeaderArr[1] and 128) = 128; 97 | Payload7 := HeaderArr[1] and %1111111; 98 | PayloadLen := Payload7; 99 | Payload16 := 0; 100 | Payload64 := 0; 101 | case Payload7 of 102 | 126: 103 | begin 104 | if ASize < 4 then 105 | exit; 106 | PayLoad16 := HeaderArr[2] shl 8; 107 | PayLoad16 := PayLoad16 or HeaderArr[3]; 108 | PayloadLen := Payload16; 109 | HeaderCount := 4; 110 | end; 111 | 127: 112 | begin 113 | if ASize < 10 then 114 | exit; 115 | Payload64 := HeaderArr[2] shl 56; 116 | Payload64 := Payload64 or (HeaderArr[3] shl 48); 117 | Payload64 := Payload64 or (HeaderArr[4] shl 40); 118 | Payload64 := Payload64 or (HeaderArr[5] shl 32); 119 | Payload64 := Payload64 or (HeaderArr[6] shl 24); 120 | Payload64 := Payload64 or (HeaderArr[7] shl 16); 121 | Payload64 := Payload64 or (HeaderArr[8] shl 8); 122 | Payload64 := Payload64 or HeaderArr[9]; 123 | PayloadLen := Payload64; 124 | HeaderCount := 10; 125 | end; 126 | end; 127 | if _mask then 128 | HeaderCount := HeaderCount + 4; 129 | 130 | Result := PayloadLen + HeaderCount; 131 | end; 132 | 133 | function TsyWebsockPackManager.GetCount: integer; 134 | begin 135 | Result := FFrameQueue.Count; 136 | end; 137 | 138 | function TsyWebsockPackManager.GetPop: TMemoryStream; 139 | begin 140 | Result := FFrameQueue.Dequeue; 141 | end; 142 | 143 | 144 | function TsyWebsockPackManager.InsertWebsocketFrame(ABuffer: TBytes; Position: integer; Size: integer): integer; 145 | begin 146 | FWebsocketBuffer.Write(ABuffer[Position], Size); 147 | end; 148 | 149 | constructor TsyWebsockPackManager.Create; 150 | begin 151 | FWebsocketBuffer := TMemoryStream.Create; 152 | FFrameSize := 0; 153 | FFrameQueue := TFrameQueue.Create; 154 | end; 155 | 156 | destructor TsyWebsockPackManager.Destroy; 157 | var 158 | mem: TMemoryStream; 159 | s: integer; 160 | begin 161 | s := FFrameQueue.Count; 162 | while FFrameQueue.Count > 0 do 163 | begin 164 | mem := FFrameQueue.Dequeue; 165 | s := mem.Size; 166 | FreeAndNil(mem); 167 | end; 168 | 169 | FreeAndNil(FFrameQueue); 170 | FreeAndNil(FWebsocketBuffer); 171 | inherited Destroy; 172 | end; 173 | 174 | 175 | procedure TsyWebsockPackManager.InsertData(AData: TBytes; ALen: integer); 176 | var 177 | tmp: integer; 178 | Mem: Pointer; 179 | // count not used byte 180 | Amount: integer; 181 | Position: integer; 182 | begin 183 | Amount := ALen; 184 | // offset to next frame 185 | Position := 0; 186 | 187 | // try frame 188 | while Amount > 0 do 189 | begin 190 | while (FFrameSize = 0) and (Amount > 0) do 191 | begin 192 | FWebsocketBuffer.Write(AData[0 + position], 1); 193 | Amount := Amount - 1; 194 | Inc(position); 195 | FFrameSize := GetWebsocketFrameSize(FWebsocketBuffer.Memory, FWebsocketBuffer.Size); 196 | if FFrameSize > 0 then 197 | break; 198 | end; 199 | while FWebsocketBuffer.Size < FFrameSize do 200 | begin 201 | tmp := FFrameSize - FWebsocketBuffer.Size; 202 | if tmp > Amount then 203 | tmp := Amount; 204 | if tmp = 0 then 205 | exit; 206 | FWebsocketBuffer.Write(AData[0 + position], tmp); 207 | Amount := Amount - tmp; 208 | Position := position + tmp; 209 | end; 210 | 211 | if FWebsocketBuffer.Size = FFrameSize then 212 | begin 213 | // save frame to queue 214 | FFrameQueue.Enqueue(FWebsocketBuffer); 215 | // create ne frame 216 | FWebsocketBuffer := TMemoryStream.Create; 217 | FFrameSize := 0; 218 | end; 219 | end; 220 | end; 221 | 222 | 223 | end. 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | -------------------------------------------------------------------------------- /src/sywebsocketserver.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : sy WebSocket Server | 3 | |==============================================================================| 4 | | Copyright (c)2020, Yuri Serebrennikov | 5 | | All rights reserved. | 6 | | | 7 | | Redistribution and use in source and binary forms, with or without | 8 | | modification, are permitted provided that the following conditions are met: | 9 | | | 10 | | Redistributions of source code must retain the above copyright notice, this | 11 | | list of conditions and the following disclaimer. | 12 | | | 13 | | Redistributions in binary form must reproduce the above copyright notice, | 14 | | this list of conditions and the following disclaimer in the documentation | 15 | | and/or other materials provided with the distribution. | 16 | | | 17 | | Neither the name of Yuri serebrennikov nor the names of its contributors may | 18 | | be used to endorse or promote products derived from this software without | 19 | | specific prior written permission. | 20 | | | 21 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 22 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 23 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 24 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 25 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 26 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 27 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 28 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 29 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 30 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 31 | | DAMAGE. | 32 | |==============================================================================| 33 | | The Initial Developer of the Original Code is Yuri Serebrennikov | 34 | | All Rights Reserved. | 35 | |==============================================================================| 36 | | (Found at URL: https://github.com/seryal/sywebsocket/) | 37 | |==============================================================================} 38 | unit syWebSocketServer; 39 | 40 | {$mode objfpc}{$H+} 41 | 42 | interface 43 | 44 | uses 45 | Classes, SysUtils, blcksock, synsock, syconnectedclient, Generics.Collections, sywebsocketcommon; 46 | 47 | type 48 | 49 | TLockedClientList = class(specialize TThreadList<TsyConnectedClient>); 50 | TClientList = specialize TList<TsyConnectedClient>; 51 | 52 | 53 | 54 | 55 | { TsyWebSocketServer } 56 | TsyWebSocketServer = class(TThread) 57 | private 58 | FClientCount: integer; 59 | FOnClientConnected: TNotifyEvent; 60 | FOnClientDisconnected: TNotifyEvent; 61 | FOnPing: TNotifyEvent; 62 | FSock: TTCPBlockSocket; 63 | FPort: integer; 64 | FLockedClientList: TLockedClientList; 65 | FDisconnectedClient: TLockedClientList; 66 | // Messages from client 67 | FMessageQueue: TMessageQueue; 68 | FOnTextMessage: TNotifyEvent; 69 | FOnBinData: TNotifyEvent; 70 | FOnCloseConnection: TNotifyEvent; 71 | procedure DoClientConnected(Sender: TObject); 72 | procedure OnClientBinaryData(Sender: TObject; BinData: TBytes); 73 | procedure OnClientClose(Sender: TObject; Reason: integer; Message: string); 74 | procedure OnClientPing(Sender: TObject; Message: string); 75 | procedure OnClientTextMessage(Sender: TObject; Message: string); 76 | procedure OnClientTerminate(Sender: TObject); 77 | 78 | procedure ClientConnectNotify; 79 | procedure TextMessageNotify; 80 | procedure CloseConnectionNotify; 81 | procedure BinDataNotify; 82 | procedure PingMessageNotify; 83 | public 84 | constructor Create(APort: integer); 85 | destructor Destroy; override; 86 | procedure Execute; override; 87 | property OnMessage: TNotifyEvent read FOnTextMessage write FOnTextMessage; 88 | property OnClientConnected: TNotifyEvent read FOnClientConnected write FOnClientConnected; 89 | property OnClientDisconnected: TNotifyEvent read FOnClientDisconnected write FOnClientDisconnected; 90 | property MessageQueue: TMessageQueue read FMessageQueue; 91 | property LockedClientList: TLockedClientList read FLockedClientList; 92 | procedure TerminateThread; 93 | end; 94 | 95 | implementation 96 | 97 | { TsyWebSocketServer } 98 | 99 | procedure TsyWebSocketServer.OnClientTerminate(Sender: TObject); 100 | var 101 | List: TClientList; 102 | begin 103 | 104 | if Terminated then 105 | Exit; 106 | if Assigned(OnClientDisconnected) then 107 | OnClientDisconnected(Sender); 108 | if not Assigned(FLockedClientList) then 109 | exit; 110 | list := FLockedClientList.LockList; 111 | try 112 | list.Remove(TsyConnectedClient(Sender)); 113 | finally 114 | FLockedClientList.UnlockList; 115 | end; 116 | end; 117 | 118 | procedure TsyWebSocketServer.ClientConnectNotify; 119 | var 120 | list: specialize TList<TsyConnectedClient>; 121 | Cl: TsyConnectedClient; 122 | begin 123 | if not Assigned(OnClientConnected) then 124 | exit; 125 | list := FDisconnectedClient.LockList; 126 | try 127 | for cl in List do 128 | OnClientConnected(cl); 129 | list.Clear; 130 | finally 131 | FDisconnectedClient.UnlockList; 132 | end; 133 | end; 134 | 135 | procedure TsyWebSocketServer.TextMessageNotify; 136 | begin 137 | if Terminated then 138 | exit; 139 | if Assigned(OnMessage) then 140 | OnMessage(self); 141 | end; 142 | 143 | procedure TsyWebSocketServer.CloseConnectionNotify; 144 | begin 145 | if Terminated then 146 | exit; 147 | if Assigned(OnMessage) then 148 | OnMessage(self); 149 | end; 150 | 151 | procedure TsyWebSocketServer.BinDataNotify; 152 | begin 153 | if Terminated then 154 | exit; 155 | if Assigned(OnMessage) then 156 | OnMessage(self); 157 | 158 | end; 159 | 160 | procedure TsyWebSocketServer.PingMessageNotify; 161 | begin 162 | if Terminated then 163 | exit; 164 | if Assigned(OnMessage) then 165 | OnMessage(self); 166 | end; 167 | 168 | procedure TsyWebSocketServer.OnClientTextMessage(Sender: TObject; Message: string); 169 | var 170 | MsgRec: TMessageRecord; 171 | begin 172 | // add message to Queue 173 | if not (Sender is TsyConnectedClient) then 174 | exit; 175 | MsgRec.Message := Message; 176 | MsgRec.Sender := TsyConnectedClient(Sender); 177 | MsgRec.Opcode := optText; 178 | MsgRec.Reason := 0; 179 | FMessageQueue.PushItem(MsgRec); 180 | 181 | // send event to MainProgram about new Text Message 182 | // The client must read the data from the queue FMessageQueue; 183 | Queue(@TextMessageNotify); 184 | end; 185 | 186 | procedure TsyWebSocketServer.OnClientClose(Sender: TObject; Reason: integer; Message: string); 187 | var 188 | MsgRec: TMessageRecord; 189 | begin 190 | // befor Close connect we CAN send message to CLient; 191 | if not (Sender is TsyConnectedClient) then 192 | exit; 193 | MsgRec.Message := Message; 194 | MsgRec.Sender := TsyConnectedClient(Sender); 195 | MsgRec.Opcode := optCloseConnect; 196 | MsgRec.Reason := Reason; 197 | FMessageQueue.PushItem(MsgRec); 198 | TsyConnectedClient(Sender).SendCloseFrame(Reason, Message); 199 | TsyConnectedClient(Sender).TerminateThread; 200 | Synchronize(@CloseConnectionNotify); 201 | end; 202 | 203 | procedure TsyWebSocketServer.OnClientPing(Sender: TObject; Message: string); 204 | var 205 | MsgRec: TMessageRecord; 206 | begin 207 | // add message to Queue 208 | if not (Sender is TsyConnectedClient) then 209 | exit; 210 | MsgRec.Message := Message; 211 | MsgRec.Sender := TsyConnectedClient(Sender); 212 | MsgRec.Opcode := optPing; 213 | MsgRec.Reason := 0; 214 | FMessageQueue.PushItem(MsgRec); 215 | 216 | // send event to MainProgram about new Text Message 217 | // The client must read the data from the queue FMessageQueue; 218 | Queue(@PingMessageNotify); 219 | end; 220 | 221 | procedure TsyWebSocketServer.OnClientBinaryData(Sender: TObject; BinData: TBytes); 222 | 223 | var 224 | MsgRec: TMessageRecord; 225 | begin 226 | // befor Close connect we CAN send message to CLient; 227 | if not (Sender is TsyConnectedClient) then 228 | exit; 229 | MsgRec.Message := ''; 230 | MsgRec.BinaryData := BinData; 231 | MsgRec.Sender := TsyConnectedClient(Sender); 232 | MsgRec.Opcode := optBinary; 233 | MsgRec.Reason := 0; 234 | FMessageQueue.PushItem(MsgRec); 235 | Queue(@BinDataNotify); 236 | end; 237 | 238 | procedure TsyWebSocketServer.DoClientConnected(Sender: TObject); 239 | begin 240 | FDisconnectedClient.Add(TsyConnectedClient(Sender)); 241 | Queue(@ClientConnectNotify); 242 | end; 243 | 244 | constructor TsyWebSocketServer.Create(APort: integer); 245 | begin 246 | FreeOnTerminate := False; 247 | FPort := APort; 248 | FSock := TTCPBlockSocket.Create; 249 | FMessageQueue := TMessageQueue.Create(); 250 | FLockedClientList := TLockedClientList.Create; 251 | FDisconnectedClient := TLockedClientList.Create; 252 | FClientCount := 1; 253 | inherited Create(True); 254 | end; 255 | 256 | destructor TsyWebSocketServer.Destroy; 257 | var 258 | list: specialize TList<TsyConnectedClient>; 259 | Cl: TsyConnectedClient; 260 | begin 261 | list := FLockedClientList.LockList; 262 | try 263 | for cl in List do 264 | begin 265 | cl.TerminateThread; 266 | end; 267 | finally 268 | FLockedClientList.UnlockList; 269 | end; 270 | 271 | list := FDisconnectedClient.LockList; 272 | try 273 | for cl in List do 274 | begin 275 | cl.TerminateThread; 276 | end; 277 | finally 278 | FDisconnectedClient.UnlockList; 279 | end; 280 | 281 | 282 | // FLockedClientList.Clear; 283 | FreeAndNil(FMessageQueue); 284 | FreeAndNil(FLockedClientList); 285 | FreeAndNil(FDisconnectedClient); 286 | FreeAndNil(FSock); 287 | inherited Destroy; 288 | end; 289 | 290 | procedure TsyWebSocketServer.Execute; 291 | var 292 | ClientSock: TSocket; 293 | Client: TsyConnectedClient; 294 | begin 295 | FSock.CreateSocket; 296 | FSock.SetLinger(True, 5000); 297 | FSock.Bind('0.0.0.0', IntToStr(FPort)); 298 | FSock.Listen; 299 | repeat 300 | if terminated then 301 | break; 302 | try 303 | if FSock.CanRead(5000) then 304 | begin 305 | if Terminated then 306 | break; 307 | ClientSock := FSock.accept; 308 | 309 | if FSock.lastError = 0 then 310 | begin 311 | // create client thread 312 | if Terminated then 313 | exit; 314 | Client := TsyConnectedClient.Create(ClientSock); 315 | FLockedClientList.Add(Client); 316 | Client.OnTerminate := @OnClientTerminate; 317 | Client.OnClientTextMessage := @OnClientTextMessage; 318 | Client.OnClientClose := @OnClientClose; 319 | Client.OnClientBinaryData := @OnClientBinaryData; 320 | Client.OnClientPing := @OnClientPing; 321 | Client.OnClientConnected := @DoClientConnected; 322 | Client.Tag := FClientCount; 323 | Inc(FClientCount); 324 | // if Assigned(OnClientConnected) then 325 | // OnClientConnected(Client); 326 | Client.Start; 327 | end; 328 | end; 329 | except 330 | 331 | end; 332 | until False; 333 | Terminate; 334 | end; 335 | 336 | procedure TsyWebSocketServer.TerminateThread; 337 | begin 338 | FSock.CloseSocket; 339 | Terminate; 340 | end; 341 | 342 | end. 343 | -------------------------------------------------------------------------------- /src/sywebsocketframe.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : sy WebSocket Server | 3 | |==============================================================================| 4 | | Copyright (c)2020, Yuri Serebrennikov | 5 | | All rights reserved. | 6 | | | 7 | | Redistribution and use in source and binary forms, with or without | 8 | | modification, are permitted provided that the following conditions are met: | 9 | | | 10 | | Redistributions of source code must retain the above copyright notice, this | 11 | | list of conditions and the following disclaimer. | 12 | | | 13 | | Redistributions in binary form must reproduce the above copyright notice, | 14 | | this list of conditions and the following disclaimer in the documentation | 15 | | and/or other materials provided with the distribution. | 16 | | | 17 | | Neither the name of Yuri serebrennikov nor the names of its contributors may | 18 | | be used to endorse or promote products derived from this software without | 19 | | specific prior written permission. | 20 | | | 21 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 22 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 23 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 24 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 25 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 26 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 27 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 28 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 29 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 30 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 31 | | DAMAGE. | 32 | |==============================================================================| 33 | | The Initial Developer of the Original Code is Yuri Serebrennikov | 34 | | All Rights Reserved. | 35 | |==============================================================================| 36 | | (Found at URL: https://github.com/seryal/sywebsocket/) | 37 | |==============================================================================} 38 | unit sywebsocketframe; 39 | 40 | {$mode objfpc}{$H+} 41 | 42 | interface 43 | 44 | uses 45 | Classes, SysUtils, sywebsocketcommon; 46 | 47 | const 48 | CLOSE_NORMAL_CLOSURE = 1000; 49 | CLOSE_GOING_AWAY = 1001; 50 | CLOSE_PROTOCOL_ERROR = 1002; 51 | CLOSE_UNSUPORTED_DATA = 1003; 52 | CLOSE_RESERVER = 1004; 53 | CLOSE_NO_STATUS_RCVD = 1005; 54 | CLOSE_ABNORMAL_CLOSURE = 1006; 55 | CLOSE_INVALID_FRAME_PAYLOAD_DATA = 1007; 56 | CLOSE_POLICY_VIOLATION = 1008; 57 | CLOSE_MESSAGE_TOO_BIG = 1009; 58 | CLOSE_MANDRATORY_EXT = 1010; 59 | CLOSE_INTERNAL_SERVER_ERROR = 1011; 60 | CLOSE_TLS_HANDSHAKE = 1015; 61 | 62 | type 63 | { TsyBaseWebsocketFrame } 64 | 65 | TsyBaseWebsocketFrame = class 66 | private 67 | FFin: boolean; 68 | FMessageStr: string; 69 | FRsv1: boolean; 70 | FRsv2: boolean; 71 | FRsv3: boolean; 72 | FOpCode: TOpcodeType; 73 | FMask: boolean; 74 | FPayloadLen: QWord; 75 | FHeaderLen: integer; 76 | FMaskValue: DWord; 77 | FReason: word; 78 | FFrame: TMemoryStream; 79 | FBinary: TBytes; 80 | function GetBinary: TBytes; 81 | function GetFrame: TMemoryStream; 82 | function GetMessageStr: string; 83 | procedure SetBinary(AValue: TBytes); 84 | procedure SetFin(AValue: boolean); 85 | procedure SetFrame(AValue: TMemoryStream); 86 | procedure SetMask(AValue: boolean); 87 | procedure SetMaskValue(AValue: DWord); 88 | procedure SetMessageStr(AValue: string); 89 | procedure SetOpcode(AValue: TOpcodeType); 90 | procedure SetPayloadLen(AValue: QWord); 91 | public 92 | // full received frame or for send 93 | property Frame: TMemoryStream read GetFrame write SetFrame; 94 | property Fin: boolean read FFin write SetFin; 95 | property OpCode: TOpcodeType read FOpCode write SetOpcode; 96 | property Mask: boolean read FMask write SetMask; 97 | property PayloadLen: QWord read FPayloadLen write SetPayloadLen; 98 | property MaskValue: DWord read FMaskValue write SetMaskValue; 99 | property MessageStr: string read GetMessageStr write SetMessageStr; 100 | property Reason: word read FReason write FReason; 101 | property Binary: TBytes read GetBinary write SetBinary; 102 | property Rsv1: boolean read FRsv1; 103 | property Rsv2: boolean read FRsv2; 104 | property Rsv3: boolean read FRsv3; 105 | constructor Create; 106 | destructor Destroy; override; 107 | end; 108 | 109 | implementation 110 | 111 | { TsyBaseWebsocketFrame } 112 | 113 | 114 | procedure TsyBaseWebsocketFrame.SetFrame(AValue: TMemoryStream); 115 | var 116 | Arr: TBytes; 117 | i: integer; 118 | _Payload7: byte; 119 | _Payload16: word; 120 | _Payload64: QWord; 121 | ustr: UTF8String; 122 | pos: integer; 123 | b: ^byte; 124 | begin 125 | if FFrame = AValue then 126 | Exit; 127 | if assigned(FFrame) then 128 | FreeAndNil(FFrame); 129 | FFrame := AValue; 130 | setlength(Arr, FFrame.Size); 131 | FFrame.Position := 0; 132 | FFrame.ReadBuffer(arr[0], FFrame.Size); 133 | FFin := (Arr[0] and 128) = 128; 134 | FRsv1 := (Arr[0] and 64) = 64; 135 | FRsv2 := (Arr[0] and 32) = 32; 136 | FRsv3 := (Arr[0] and 16) = 16; 137 | FOpCode := TOpcodeType(Arr[0] and 15); 138 | FMask := (Arr[1] and 128) = 128; 139 | _Payload7 := Arr[1] and 127; 140 | FPayloadLen := _Payload7; 141 | pos := 2; 142 | case _PayLoad7 of 143 | 126: 144 | begin 145 | Move(Arr[2], _Payload16, 2); 146 | _Payload16 := SwapEndian(_Payload16); 147 | FPayloadLen := _Payload16; 148 | pos := 4; 149 | end; 150 | 127: 151 | begin 152 | Move(Arr[2], _Payload64, 8); 153 | _Payload64 := SwapEndian(_Payload64); 154 | FPayloadLen := _Payload64; 155 | pos := 10; 156 | end; 157 | end; 158 | 159 | { TODO : // correct? need check mask -> pos+4 -> check payloadlen } 160 | if (FMask) and (FPayloadLen > 0) then 161 | begin 162 | move(arr[pos], FMaskValue, 4); 163 | pos := pos + 4; 164 | b := FFrame.Memory + pos; 165 | for i := 0 to FPayloadLen - 1 do 166 | begin 167 | b^ := b^ xor ((FMaskValue shr ((i mod 4) * 8)) and $FF); 168 | Inc(b); 169 | end; 170 | end; 171 | FHeaderLen := pos; 172 | case OpCode of 173 | optCloseConnect: 174 | begin 175 | if PayloadLen = 0 then 176 | FReason := CLOSE_NORMAL_CLOSURE; 177 | if PayloadLen = 1 then 178 | FReason := CLOSE_PROTOCOL_ERROR; 179 | if PayloadLen >= 2 then 180 | begin 181 | FPayloadLen := FPayloadLen - 2; 182 | FFrame.Position := FHeaderLen; 183 | FFrame.ReadBuffer(Freason, 2); 184 | FReason := SwapEndian(FReason); 185 | FHeaderLen := FHeaderLen + 2; 186 | end; 187 | end; 188 | end; 189 | end; 190 | 191 | procedure TsyBaseWebsocketFrame.SetMask(AValue: boolean); 192 | begin 193 | if FMask = AValue then 194 | Exit; 195 | FMask := AValue; 196 | end; 197 | 198 | procedure TsyBaseWebsocketFrame.SetMaskValue(AValue: DWord); 199 | begin 200 | if FMaskValue = AValue then 201 | Exit; 202 | FMaskValue := AValue; 203 | end; 204 | 205 | procedure TsyBaseWebsocketFrame.SetMessageStr(AValue: string); 206 | type 207 | THeadBuffer = array[0..13] of byte; 208 | var 209 | ustr: UTF8String; 210 | Buffer: TBytes; 211 | len: integer; 212 | begin 213 | /// 214 | ustr := AValue; 215 | len := length(ustr); 216 | FPayloadLen := len; 217 | if opcode = optCloseConnect then 218 | begin 219 | SetLength(ustr, len + 2); 220 | if FPayloadLen > 0 then 221 | move(ustr[1], ustr[3], len); 222 | ustr[2] := chr(FReason and $FF); 223 | ustr[1] := chr((FReason and $FF00) shr 8); 224 | len := len + 2; 225 | FPayloadLen := FPayloadLen + 2; 226 | end; 227 | 228 | setlength(Buffer, len); 229 | if len > 0 then 230 | move(ustr[1], Buffer[0], len); 231 | SetBinary(Buffer); 232 | end; 233 | 234 | procedure TsyBaseWebsocketFrame.SetOpcode(AValue: TOpcodeType); 235 | begin 236 | if FOpCode = AValue then 237 | Exit; 238 | FOpCode := AValue; 239 | end; 240 | 241 | procedure TsyBaseWebsocketFrame.SetPayloadLen(AValue: QWord); 242 | begin 243 | if FPayloadLen = AValue then 244 | Exit; 245 | FPayloadLen := AValue; 246 | end; 247 | 248 | constructor TsyBaseWebsocketFrame.Create; 249 | begin 250 | FFrame := TMemoryStream.Create; 251 | end; 252 | 253 | destructor TsyBaseWebsocketFrame.Destroy; 254 | begin 255 | if assigned(FFrame) then 256 | FreeAndNil(FFrame); 257 | inherited Destroy; 258 | end; 259 | 260 | function TsyBaseWebsocketFrame.GetFrame: TMemoryStream; 261 | begin 262 | Result := FFrame; 263 | end; 264 | 265 | function TsyBaseWebsocketFrame.GetMessageStr: string; 266 | var 267 | ustr: UTF8String; 268 | begin 269 | Result := ''; 270 | if FPayloadLen > 0 then 271 | begin 272 | SetLength(ustr, FPayloadLen); 273 | FFrame.Position := FHeaderLen; 274 | FFrame.ReadBuffer(ustr[1], FPayloadLen); 275 | Result := ustr; 276 | end; 277 | end; 278 | 279 | function TsyBaseWebsocketFrame.GetBinary: TBytes; 280 | begin 281 | SetLength(Result, FPayloadLen); 282 | if FPayloadLen > 0 then 283 | begin 284 | FFrame.Position := FHeaderLen; 285 | FFrame.ReadBuffer(Result[0], FPayloadLen); 286 | SetLength(Result, FPayloadLen); 287 | end; 288 | end; 289 | 290 | procedure TsyBaseWebsocketFrame.SetBinary(AValue: TBytes); 291 | type 292 | THeadBuffer = array[0..13] of byte; 293 | var 294 | Data: TBytes; 295 | len16: word; 296 | len64: QWord; 297 | fullsize: integer; 298 | plType: byte; 299 | HeadBuffer: ^THeadBuffer; 300 | tmp: ^THeadBuffer; 301 | i: integer; 302 | begin 303 | // forming websocket frame for send 304 | FPayloadLen := Length(AValue); 305 | SetLength(Data, FPayloadLen); 306 | if FPayloadLen > 0 then 307 | move(AValue[0], Data[0], FPayloadLen); 308 | // len := 2; 309 | fullsize := FPayloadLen + 2; 310 | pltype := 1; 311 | if FPayloadLen > 125 then 312 | begin 313 | fullsize := fullsize + 2; 314 | pltype := 2; 315 | end; 316 | if FPayloadLen > High(word) then 317 | begin 318 | fullsize := fullsize + 6; 319 | plType := 3; 320 | end; 321 | if Fmask then 322 | fullsize := fullsize + 4; 323 | 324 | FFrame.SetSize(fullsize); 325 | 326 | HeadBuffer := FFrame.Memory; 327 | HeadBuffer^[0] := 128; 328 | HeadBuffer^[0] := HeadBuffer^[0] or integer(FOpcode); 329 | 330 | // set mask 331 | if Fmask then 332 | begin 333 | HeadBuffer^[1] := 128; 334 | FMaskValue := Random($FFFFFFFF); 335 | FMaskValue := 0; 336 | end 337 | else 338 | HeadBuffer^[1] := 0; 339 | 340 | 341 | case plType of 342 | 1: 343 | begin 344 | HeadBuffer^[1] := HeadBuffer^[1] or FPayloadLen; 345 | move(FMaskValue, HeadBuffer^[2], 4); 346 | end; 347 | 2: 348 | begin 349 | len16 := FPayloadLen; 350 | len16 := SwapEndian(len16); 351 | HeadBuffer^[1] := HeadBuffer^[1] or 126; 352 | move(len16, HeadBuffer^[2], 2); 353 | move(FMaskValue, HeadBuffer^[4], 4); 354 | end; 355 | 3: 356 | begin 357 | len64 := FPayloadLen; 358 | len64 := SwapEndian(len64); 359 | HeadBuffer^[1] := HeadBuffer^[1] or 127; 360 | move(len64, HeadBuffer^[2], 8); 361 | move(FMaskValue, HeadBuffer^[10], 4); 362 | end; 363 | end; 364 | FHeaderLen := fullsize - FPayloadLen; 365 | FFrame.Position := fullsize - FPayloadLen; 366 | if FPayloadLen = 0 then 367 | exit; 368 | // encode Payload data 369 | if mask then 370 | begin 371 | //FMaskValue := SwapEndian(FMaskValue); 372 | for i := 0 to FPayloadLen - 1 do 373 | Data[i] := Data[i] xor ((FMaskValue shr ((i mod 4) * 8)) and $FF); 374 | 375 | end; 376 | 377 | FPayloadLen := FFrame.Write(Data[0], FPayloadLen); 378 | 379 | // HeadBuffer := FFrame.Memory; 380 | end; 381 | 382 | procedure TsyBaseWebsocketFrame.SetFin(AValue: boolean); 383 | begin 384 | if FFin = AValue then 385 | Exit; 386 | FFin := AValue; 387 | end; 388 | 389 | 390 | end. 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | 401 | 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | -------------------------------------------------------------------------------- /demo/testApp.lps: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectSession> 4 | <PathDelim Value="\"/> 5 | <Version Value="12"/> 6 | <BuildModes Active="Debug"/> 7 | <Units Count="45"> 8 | <Unit0> 9 | <Filename Value="testApp.lpr"/> 10 | <IsPartOfProject Value="True"/> 11 | <EditorIndex Value="3"/> 12 | <CursorPos Y="16"/> 13 | <UsageCount Value="201"/> 14 | <Loaded Value="True"/> 15 | </Unit0> 16 | <Unit1> 17 | <Filename Value="main.pas"/> 18 | <IsPartOfProject Value="True"/> 19 | <ComponentName Value="Form1"/> 20 | <HasResources Value="True"/> 21 | <ResourceBaseClass Value="Form"/> 22 | <IsVisibleTab Value="True"/> 23 | <TopLine Value="113"/> 24 | <CursorPos X="45" Y="127"/> 25 | <UsageCount Value="201"/> 26 | <Loaded Value="True"/> 27 | <LoadedDesigner Value="True"/> 28 | </Unit1> 29 | <Unit2> 30 | <Filename Value="sywebsocketserver.pas"/> 31 | <UnitName Value="syWebSocketServer"/> 32 | <EditorIndex Value="-1"/> 33 | <CursorPos X="85" Y="7"/> 34 | <UsageCount Value="201"/> 35 | <Bookmarks Count="2"> 36 | <Item0 Y="250" ID="1"/> 37 | <Item1 X="33" Y="56" ID="3"/> 38 | </Bookmarks> 39 | </Unit2> 40 | <Unit3> 41 | <Filename Value="syconnectedclient.pas"/> 42 | <EditorIndex Value="-1"/> 43 | <TopLine Value="536"/> 44 | <CursorPos Y="399"/> 45 | <UsageCount Value="201"/> 46 | <Bookmarks Count="1"> 47 | <Item0 Y="235" ID="9"/> 48 | </Bookmarks> 49 | </Unit3> 50 | <Unit4> 51 | <Filename Value="httpheader.pas"/> 52 | <EditorIndex Value="-1"/> 53 | <CursorPos X="30" Y="8"/> 54 | <UsageCount Value="205"/> 55 | </Unit4> 56 | <Unit5> 57 | <Filename Value="websocpackmanager.pas"/> 58 | <EditorIndex Value="-1"/> 59 | <CursorPos X="24" Y="8"/> 60 | <UsageCount Value="175"/> 61 | </Unit5> 62 | <Unit6> 63 | <Filename Value="websocketframe.pas"/> 64 | <EditorIndex Value="-1"/> 65 | <CursorPos Y="259"/> 66 | <UsageCount Value="200"/> 67 | <Bookmarks Count="1"> 68 | <Item0 X="14" Y="13" ID="2"/> 69 | </Bookmarks> 70 | </Unit6> 71 | <Unit7> 72 | <Filename Value="websocketmessage.pas"/> 73 | <EditorIndex Value="-1"/> 74 | <CursorPos X="29" Y="8"/> 75 | <UsageCount Value="46"/> 76 | </Unit7> 77 | <Unit8> 78 | <Filename Value="baseframe.pas"/> 79 | <EditorIndex Value="-1"/> 80 | <TopLine Value="379"/> 81 | <CursorPos X="53" Y="402"/> 82 | <UsageCount Value="187"/> 83 | <Bookmarks Count="1"> 84 | <Item0 Y="364" ID="3"/> 85 | </Bookmarks> 86 | </Unit8> 87 | <Unit9> 88 | <Filename Value="C:\Users\yus\AppData\Local\lazarus\onlinepackagemanager\packages\synapse40.1\blcksock.pas"/> 89 | <EditorIndex Value="-1"/> 90 | <TopLine Value="2583"/> 91 | <CursorPos Y="2598"/> 92 | <UsageCount Value="12"/> 93 | </Unit9> 94 | <Unit10> 95 | <Filename Value="C:\lazarus\fpc\3.0.4\source\rtl\objpas\classes\classesh.inc"/> 96 | <EditorIndex Value="-1"/> 97 | <TopLine Value="1707"/> 98 | <CursorPos X="14" Y="1717"/> 99 | <UsageCount Value="10"/> 100 | </Unit10> 101 | <Unit11> 102 | <Filename Value="C:\lazarus\components\sparta\generics\sparta_generics.pas"/> 103 | <UnitName Value="sparta_Generics"/> 104 | <EditorIndex Value="-1"/> 105 | <CursorPos X="19" Y="9"/> 106 | <UsageCount Value="4"/> 107 | </Unit11> 108 | <Unit12> 109 | <Filename Value="C:\lazarus\components\sparta\generics\source\generics.collections.pas"/> 110 | <UnitName Value="Generics.Collections"/> 111 | <EditorIndex Value="-1"/> 112 | <TopLine Value="1928"/> 113 | <CursorPos Y="1944"/> 114 | <UsageCount Value="10"/> 115 | </Unit12> 116 | <Unit13> 117 | <Filename Value="C:\lazarus\lcl\include\control.inc"/> 118 | <EditorIndex Value="-1"/> 119 | <TopLine Value="2896"/> 120 | <CursorPos Y="2913"/> 121 | <UsageCount Value="4"/> 122 | </Unit13> 123 | <Unit14> 124 | <Filename Value="C:\lazarus\lcl\include\buttoncontrol.inc"/> 125 | <EditorIndex Value="-1"/> 126 | <TopLine Value="4"/> 127 | <CursorPos Y="22"/> 128 | <UsageCount Value="4"/> 129 | </Unit14> 130 | <Unit15> 131 | <Filename Value="C:\lazarus\lcl\include\buttons.inc"/> 132 | <EditorIndex Value="-1"/> 133 | <TopLine Value="152"/> 134 | <CursorPos Y="170"/> 135 | <UsageCount Value="4"/> 136 | </Unit15> 137 | <Unit16> 138 | <Filename Value="C:\lazarus\components\lazutils\lazcollections.pas"/> 139 | <UnitName Value="lazCollections"/> 140 | <EditorIndex Value="-1"/> 141 | <CursorPos X="54" Y="15"/> 142 | <UsageCount Value="10"/> 143 | </Unit16> 144 | <Unit17> 145 | <Filename Value="C:\lazarus\lcl\lclmessageglue.pas"/> 146 | <UnitName Value="LCLMessageGlue"/> 147 | <EditorIndex Value="-1"/> 148 | <TopLine Value="122"/> 149 | <CursorPos Y="116"/> 150 | <UsageCount Value="9"/> 151 | </Unit17> 152 | <Unit18> 153 | <Filename Value="C:\lazarus\fpc\3.0.4\source\rtl\objpas\sysutils\sysutilh.inc"/> 154 | <EditorIndex Value="-1"/> 155 | <TopLine Value="89"/> 156 | <CursorPos X="4" Y="104"/> 157 | <UsageCount Value="22"/> 158 | </Unit18> 159 | <Unit19> 160 | <Filename Value="C:\lazarus\components\lazutils\lazutf8.pas"/> 161 | <UnitName Value="LazUTF8"/> 162 | <EditorIndex Value="-1"/> 163 | <UsageCount Value="10"/> 164 | </Unit19> 165 | <Unit20> 166 | <Filename Value="..\sywebsocketframe.pas"/> 167 | <EditorIndex Value="-1"/> 168 | <TopLine Value="13"/> 169 | <CursorPos Y="38"/> 170 | <UsageCount Value="10"/> 171 | </Unit20> 172 | <Unit21> 173 | <Filename Value="..\sywebsocketmessage.pas"/> 174 | <EditorIndex Value="-1"/> 175 | <TopLine Value="13"/> 176 | <CursorPos Y="38"/> 177 | <UsageCount Value="10"/> 178 | </Unit21> 179 | <Unit22> 180 | <Filename Value="..\sywebsocketpackmanager.pas"/> 181 | <EditorIndex Value="-1"/> 182 | <CursorPos Y="38"/> 183 | <UsageCount Value="10"/> 184 | </Unit22> 185 | <Unit23> 186 | <Filename Value="..\syconnectedclient.pas"/> 187 | <EditorIndex Value="-1"/> 188 | <TopLine Value="13"/> 189 | <CursorPos Y="38"/> 190 | <UsageCount Value="10"/> 191 | </Unit23> 192 | <Unit24> 193 | <Filename Value="..\sywebsocketserver.pas"/> 194 | <UnitName Value="syWebSocketServer"/> 195 | <EditorIndex Value="-1"/> 196 | <TopLine Value="13"/> 197 | <CursorPos Y="38"/> 198 | <UsageCount Value="10"/> 199 | </Unit24> 200 | <Unit25> 201 | <Filename Value="..\syhttpheader.pas"/> 202 | <EditorIndex Value="-1"/> 203 | <TopLine Value="14"/> 204 | <CursorPos X="34" Y="25"/> 205 | <UsageCount Value="10"/> 206 | </Unit25> 207 | <Unit26> 208 | <Filename Value="..\src\sywebsocketframe.pas"/> 209 | <EditorIndex Value="-1"/> 210 | <TopLine Value="318"/> 211 | <CursorPos Y="333"/> 212 | <UsageCount Value="11"/> 213 | <Bookmarks Count="2"> 214 | <Item0 X="3" Y="374" ID="1"/> 215 | <Item1 X="12" Y="165" ID="2"/> 216 | </Bookmarks> 217 | </Unit26> 218 | <Unit27> 219 | <Filename Value="..\src\sywebsocketserver.pas"/> 220 | <UnitName Value="syWebSocketServer"/> 221 | <EditorIndex Value="-1"/> 222 | <TopLine Value="268"/> 223 | <CursorPos X="48" Y="288"/> 224 | <UsageCount Value="11"/> 225 | </Unit27> 226 | <Unit28> 227 | <Filename Value="..\src\syconnectedclient.pas"/> 228 | <EditorIndex Value="-1"/> 229 | <TopLine Value="148"/> 230 | <CursorPos X="35" Y="181"/> 231 | <UsageCount Value="14"/> 232 | <Bookmarks Count="1"> 233 | <Item0 X="8" Y="181" ID="1"/> 234 | </Bookmarks> 235 | </Unit28> 236 | <Unit29> 237 | <Filename Value="..\src\sywebsocketclient.pas"/> 238 | <EditorIndex Value="1"/> 239 | <TopLine Value="56"/> 240 | <CursorPos Y="68"/> 241 | <UsageCount Value="16"/> 242 | <Bookmarks Count="3"> 243 | <Item0 Y="165" ID="2"/> 244 | <Item1 Y="155" ID="3"/> 245 | <Item2 X="3" Y="69" ID="1"/> 246 | </Bookmarks> 247 | <Loaded Value="True"/> 248 | </Unit29> 249 | <Unit30> 250 | <Filename Value="..\src\sywebsocketcommon.pas"/> 251 | <EditorIndex Value="-1"/> 252 | <TopLine Value="38"/> 253 | <CursorPos Y="46"/> 254 | <UsageCount Value="23"/> 255 | </Unit30> 256 | <Unit31> 257 | <Filename Value="C:\lazarus\fpc\3.0.4\source\packages\hash\src\sha1.pp"/> 258 | <EditorIndex Value="-1"/> 259 | <TopLine Value="28"/> 260 | <CursorPos X="10" Y="44"/> 261 | <UsageCount Value="11"/> 262 | </Unit31> 263 | <Unit32> 264 | <Filename Value="C:\lazarus\lcl\lclintf.pas"/> 265 | <UnitName Value="LCLIntf"/> 266 | <EditorIndex Value="-1"/> 267 | <TopLine Value="41"/> 268 | <CursorPos X="22" Y="52"/> 269 | <UsageCount Value="10"/> 270 | </Unit32> 271 | <Unit33> 272 | <Filename Value="..\src\sywebsocketmessage.pas"/> 273 | <EditorIndex Value="-1"/> 274 | <TopLine Value="64"/> 275 | <CursorPos Y="89"/> 276 | <UsageCount Value="10"/> 277 | </Unit33> 278 | <Unit34> 279 | <Filename Value="C:\lazarus\fpc\3.0.4\source\rtl\objpas\classes\lists.inc"/> 280 | <EditorIndex Value="-1"/> 281 | <TopLine Value="620"/> 282 | <CursorPos Y="636"/> 283 | <UsageCount Value="10"/> 284 | </Unit34> 285 | <Unit35> 286 | <Filename Value="C:\lazarus\lcl\interfaces\win32\win32callback.inc"/> 287 | <EditorIndex Value="-1"/> 288 | <TopLine Value="1978"/> 289 | <CursorPos Y="1993"/> 290 | <UsageCount Value="10"/> 291 | </Unit35> 292 | <Unit36> 293 | <Filename Value="..\src\sywebsocketpackmanager.pas"/> 294 | <EditorIndex Value="-1"/> 295 | <TopLine Value="186"/> 296 | <CursorPos X="28" Y="192"/> 297 | <UsageCount Value="11"/> 298 | </Unit36> 299 | <Unit37> 300 | <Filename Value="C:\lazarus\fpc\3.2.0\source\rtl\objpas\classes\classesh.inc"/> 301 | <EditorIndex Value="-1"/> 302 | <TopLine Value="100"/> 303 | <CursorPos X="3" Y="118"/> 304 | <UsageCount Value="10"/> 305 | </Unit37> 306 | <Unit38> 307 | <Filename Value="C:\Users\yus\AppData\Local\lazarus\onlinepackagemanager\packages\synapse40.1\httpsend.pas"/> 308 | <EditorIndex Value="4"/> 309 | <TopLine Value="349"/> 310 | <CursorPos Y="363"/> 311 | <UsageCount Value="12"/> 312 | <Loaded Value="True"/> 313 | </Unit38> 314 | <Unit39> 315 | <Filename Value="C:\Users\yus\AppData\Local\lazarus\onlinepackagemanager\packages\synapse40.1\synautil.pas"/> 316 | <EditorIndex Value="5"/> 317 | <TopLine Value="245"/> 318 | <CursorPos X="10" Y="260"/> 319 | <UsageCount Value="12"/> 320 | <Loaded Value="True"/> 321 | </Unit39> 322 | <Unit40> 323 | <Filename Value="C:\Users\yus\AppData\Local\lazarus\onlinepackagemanager\packages\synapse40.1\ssl_openssl.pas"/> 324 | <EditorIndex Value="-1"/> 325 | <UsageCount Value="10"/> 326 | </Unit40> 327 | <Unit41> 328 | <Filename Value="C:\lazarus_web\lazarus\lcl\include\control.inc"/> 329 | <EditorIndex Value="-1"/> 330 | <TopLine Value="3598"/> 331 | <CursorPos Y="3617"/> 332 | <UsageCount Value="10"/> 333 | </Unit41> 334 | <Unit42> 335 | <Filename Value="C:\lazarus_web\lazarus\lcl\include\customedit.inc"/> 336 | <EditorIndex Value="-1"/> 337 | <TopLine Value="515"/> 338 | <CursorPos Y="535"/> 339 | <UsageCount Value="10"/> 340 | </Unit42> 341 | <Unit43> 342 | <Filename Value="C:\lazarus_web\fpcsrc\rtl\objpas\classes\classesh.inc"/> 343 | <EditorIndex Value="-1"/> 344 | <TopLine Value="1959"/> 345 | <CursorPos X="15" Y="1976"/> 346 | <UsageCount Value="10"/> 347 | </Unit43> 348 | <Unit44> 349 | <Filename Value="C:\lazarus_web\config_lazarus\onlinepackagemanager\packages\synapse40.1\blcksock.pas"/> 350 | <EditorIndex Value="2"/> 351 | <TopLine Value="2598"/> 352 | <CursorPos Y="2618"/> 353 | <UsageCount Value="10"/> 354 | <Loaded Value="True"/> 355 | </Unit44> 356 | </Units> 357 | <OtherDefines Count="1"> 358 | <Define0 Value="DEBUG"/> 359 | </OtherDefines> 360 | <JumpHistory Count="30" HistoryIndex="29"> 361 | <Position1> 362 | <Filename Value="..\src\sywebsocketclient.pas"/> 363 | <Caret Line="67" TopLine="47"/> 364 | </Position1> 365 | <Position2> 366 | <Filename Value="..\src\sywebsocketclient.pas"/> 367 | <Caret Line="68" TopLine="47"/> 368 | </Position2> 369 | <Position3> 370 | <Filename Value="..\src\sywebsocketclient.pas"/> 371 | <Caret Line="70" TopLine="47"/> 372 | </Position3> 373 | <Position4> 374 | <Filename Value="..\src\sywebsocketclient.pas"/> 375 | <Caret Line="71" TopLine="47"/> 376 | </Position4> 377 | <Position5> 378 | <Filename Value="..\src\sywebsocketclient.pas"/> 379 | <Caret Line="73" TopLine="47"/> 380 | </Position5> 381 | <Position6> 382 | <Filename Value="..\src\sywebsocketclient.pas"/> 383 | <Caret Line="74" TopLine="47"/> 384 | </Position6> 385 | <Position7> 386 | <Filename Value="..\src\sywebsocketclient.pas"/> 387 | <Caret Line="75" TopLine="66"/> 388 | </Position7> 389 | <Position8> 390 | <Filename Value="..\src\sywebsocketclient.pas"/> 391 | <Caret Line="78" TopLine="66"/> 392 | </Position8> 393 | <Position9> 394 | <Filename Value="..\src\sywebsocketclient.pas"/> 395 | <Caret Line="79" TopLine="66"/> 396 | </Position9> 397 | <Position10> 398 | <Filename Value="..\src\sywebsocketclient.pas"/> 399 | <Caret Line="80" TopLine="66"/> 400 | </Position10> 401 | <Position11> 402 | <Filename Value="..\src\sywebsocketclient.pas"/> 403 | <Caret Line="81" TopLine="66"/> 404 | </Position11> 405 | <Position12> 406 | <Filename Value="..\src\sywebsocketclient.pas"/> 407 | <Caret Line="83" TopLine="66"/> 408 | </Position12> 409 | <Position13> 410 | <Filename Value="..\src\sywebsocketclient.pas"/> 411 | <Caret Line="85" TopLine="75"/> 412 | </Position13> 413 | <Position14> 414 | <Filename Value="..\src\sywebsocketclient.pas"/> 415 | <Caret Line="86" TopLine="75"/> 416 | </Position14> 417 | <Position15> 418 | <Filename Value="..\src\sywebsocketclient.pas"/> 419 | <Caret Line="214" TopLine="194"/> 420 | </Position15> 421 | <Position16> 422 | <Filename Value="..\src\sywebsocketclient.pas"/> 423 | <Caret Line="228" TopLine="196"/> 424 | </Position16> 425 | <Position17> 426 | <Filename Value="..\src\sywebsocketclient.pas"/> 427 | <Caret Line="67" TopLine="47"/> 428 | </Position17> 429 | <Position18> 430 | <Filename Value="main.pas"/> 431 | <Caret Line="127" Column="45" TopLine="113"/> 432 | </Position18> 433 | <Position19> 434 | <Filename Value="..\src\sywebsocketclient.pas"/> 435 | <Caret Line="75" TopLine="47"/> 436 | </Position19> 437 | <Position20> 438 | <Filename Value="..\src\sywebsocketclient.pas"/> 439 | <Caret Line="76" TopLine="47"/> 440 | </Position20> 441 | <Position21> 442 | <Filename Value="..\src\sywebsocketclient.pas"/> 443 | <Caret Line="79" TopLine="47"/> 444 | </Position21> 445 | <Position22> 446 | <Filename Value="..\src\sywebsocketclient.pas"/> 447 | <Caret Line="74" Column="12" TopLine="48"/> 448 | </Position22> 449 | <Position23> 450 | <Filename Value="..\src\sywebsocketclient.pas"/> 451 | <Caret Line="33" Column="16" TopLine="13"/> 452 | </Position23> 453 | <Position24> 454 | <Filename Value="..\src\sywebsocketclient.pas"/> 455 | <Caret Line="166" Column="54" TopLine="159"/> 456 | </Position24> 457 | <Position25> 458 | <Filename Value="..\src\sywebsocketclient.pas"/> 459 | <Caret Line="75" TopLine="56"/> 460 | </Position25> 461 | <Position26> 462 | <Filename Value="..\src\sywebsocketclient.pas"/> 463 | <Caret Line="76" TopLine="56"/> 464 | </Position26> 465 | <Position27> 466 | <Filename Value="..\src\sywebsocketclient.pas"/> 467 | <Caret Line="79" TopLine="56"/> 468 | </Position27> 469 | <Position28> 470 | <Filename Value="..\src\sywebsocketclient.pas"/> 471 | <Caret Line="80" TopLine="56"/> 472 | </Position28> 473 | <Position29> 474 | <Filename Value="..\src\sywebsocketclient.pas"/> 475 | <Caret Line="81" TopLine="56"/> 476 | </Position29> 477 | <Position30> 478 | <Filename Value="..\src\sywebsocketclient.pas"/> 479 | <Caret Line="68" TopLine="56"/> 480 | </Position30> 481 | </JumpHistory> 482 | <RunParams> 483 | <FormatVersion Value="2"/> 484 | <Modes ActiveMode=""/> 485 | </RunParams> 486 | </ProjectSession> 487 | <Debugging> 488 | <Watches> 489 | <Item> 490 | <Expression Value="Reason"/> 491 | </Item> 492 | <Item> 493 | <Expression Value="Value"/> 494 | </Item> 495 | <Item> 496 | <Expression Value="str"/> 497 | </Item> 498 | <Item> 499 | <Expression Value="headerkey"/> 500 | </Item> 501 | <Item> 502 | <Expression Value="headervalue"/> 503 | </Item> 504 | </Watches> 505 | </Debugging> 506 | </CONFIG> 507 | -------------------------------------------------------------------------------- /src/syconnectedclient.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : sy WebSocket Server | 3 | |==============================================================================| 4 | | Copyright (c)2020, Yuri Serebrennikov | 5 | | All rights reserved. | 6 | | | 7 | | Redistribution and use in source and binary forms, with or without | 8 | | modification, are permitted provided that the following conditions are met: | 9 | | | 10 | | Redistributions of source code must retain the above copyright notice, this | 11 | | list of conditions and the following disclaimer. | 12 | | | 13 | | Redistributions in binary form must reproduce the above copyright notice, | 14 | | this list of conditions and the following disclaimer in the documentation | 15 | | and/or other materials provided with the distribution. | 16 | | | 17 | | Neither the name of Yuri serebrennikov nor the names of its contributors may | 18 | | be used to endorse or promote products derived from this software without | 19 | | specific prior written permission. | 20 | | | 21 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 22 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 23 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 24 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 25 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 26 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 27 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 28 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 29 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 30 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 31 | | DAMAGE. | 32 | |==============================================================================| 33 | | The Initial Developer of the Original Code is Yuri Serebrennikov | 34 | | All Rights Reserved. | 35 | |==============================================================================| 36 | | (Found at URL: https://github.com/seryal/sywebsocket/) | 37 | |==============================================================================} 38 | unit syconnectedclient; 39 | 40 | { TODO : Exceptions for errors } 41 | {$mode objfpc}{$H+} 42 | 43 | interface 44 | 45 | uses 46 | Classes, SysUtils, blcksock, synautil, synsock, sha1, base64, sywebsocketpackmanager, 47 | syhttpheader, sywebsocketframe, sywebsocketmessage, sywebsocketcommon; 48 | 49 | const 50 | TIMEOUT = 5000; 51 | ANSWER_STRING = 'It''s sy Websocket Server'; 52 | 53 | type 54 | 55 | TOnClientTextMessage = procedure(Sender: TObject; Message: string) of object; 56 | TOnClientCloseConnect = procedure(Sender: TObject; Reason: integer; Message: string) of object; 57 | TOnClientBinaryMessage = procedure(Sender: TObject; BinData: TBytes) of object; 58 | 59 | 60 | { TsyConnectedClient } 61 | 62 | TsyConnectedClient = class(TThread) 63 | private 64 | FCritSection: TRTLCriticalSection; 65 | FOnClientPing: TOnClientTextMessage; 66 | FTerminateEvent: PRTLEvent; 67 | FSock: TTCPBlockSocket; 68 | FWebSocket: boolean; 69 | FHandShake: boolean; 70 | FOnClientTextMessage: TOnClientTextMessage; 71 | FOnClientBinaryData: TOnClientBinaryMessage; 72 | FOnClientClose: TOnClientCloseConnect; 73 | FOnClientConnected: TNotifyEvent; 74 | FTag: integer; 75 | FCookie: string; 76 | FWebsocketFrame: TsyWebsockPackManager; 77 | function MyEncodeBase64(sha1: TSHA1Digest): string; 78 | procedure Execute; override; 79 | procedure OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); 80 | procedure SendHTTPAnswer; 81 | procedure SendHandShake(ASecWebSocketKey: string); 82 | function GetWebSocketKey(AHeader: TStringList): string; 83 | procedure ProcessData; 84 | public 85 | constructor Create(hSock: TSocket); 86 | destructor Destroy; override; 87 | procedure TerminateThread; 88 | 89 | // комманды отправки 90 | procedure SendCloseFrame(AReason: integer; AMessage: string); 91 | procedure SendMessageFrame(AMessage: string); 92 | procedure SendBinaryFrame(ABinData: TBytes); 93 | procedure SendPong(AMessage: string); 94 | 95 | property OnClientTextMessage: TOnClientTextMessage read FOnClientTextMessage write FOnClientTextMessage; 96 | property OnClientBinaryData: TOnClientBinaryMessage read FOnClientBinaryData write FOnClientBinaryData; 97 | property OnClientClose: TOnClientCloseConnect read FOnClientClose write FOnClientClose; 98 | property OnClientPing: TOnClientTextMessage read FOnClientPing write FOnClientPing; 99 | property OnClientConnected: TNotifyEvent read FOnClientConnected write FOnClientConnected; 100 | property Tag: integer read FTag write FTag; 101 | end; 102 | 103 | implementation 104 | 105 | 106 | 107 | { TsyConnectedClient } 108 | 109 | 110 | function TsyConnectedClient.MyEncodeBase64(sha1: TSHA1Digest): string; 111 | var 112 | EncodedStream: TStringStream; 113 | Encoder: TBase64EncodingStream; 114 | Output: string; 115 | begin 116 | EncodedStream := TStringStream.Create(''); 117 | try 118 | Encoder := TBase64EncodingStream.Create(EncodedStream); 119 | try 120 | encoder.WriteBuffer(sha1, length(sha1)); 121 | Encoder.Flush; 122 | Output := EncodedStream.DataString; 123 | finally 124 | FreeAndNil(Encoder); 125 | end; 126 | finally 127 | FreeAndNil(EncodedStream); 128 | end; 129 | Result := Output; 130 | end; 131 | 132 | procedure TsyConnectedClient.Execute; 133 | var 134 | s: string; 135 | HTTPRec: THTTPRecord; 136 | Header: TStringList; 137 | 138 | begin 139 | FSock.OnStatus := @OnStatus; 140 | FWebSocket := False; 141 | FHandShake := False; 142 | s := FSock.RecvString(TIMEOUT); 143 | 144 | if FSock.LastError <> 0 then 145 | exit; 146 | 147 | HTTPRec.Parse(s); 148 | // if not HTTP request then close connection 149 | if HTTPRec.Protocol <> 'HTTP/1.1' then 150 | exit; 151 | 152 | // read header 153 | Header := TStringList.Create; 154 | try 155 | repeat 156 | s := FSock.RecvString(TIMEOUT); 157 | Header.Add(s); 158 | until s = ''; 159 | FWebSocket := IsWebSocketConnect(Header); 160 | 161 | if FWebSocket then 162 | begin 163 | if not FHandShake then 164 | begin 165 | // Handshake with client 166 | SendHandShake(GetWebSocketKey(Header)); 167 | FHandShake := True; 168 | end; 169 | end 170 | else 171 | begin 172 | // Send Answer to browser 173 | SendHTTPAnswer; 174 | exit; 175 | end; 176 | finally 177 | FreeAndNil(Header); 178 | end; 179 | if FHandShake then 180 | begin 181 | if Assigned(OnClientConnected) then 182 | OnClientConnected(Self); 183 | ProcessData; 184 | end; 185 | 186 | TerminateThread; 187 | end; 188 | 189 | 190 | 191 | procedure TsyConnectedClient.SendHTTPAnswer; 192 | var 193 | AnswerStr: string; 194 | begin 195 | AnswerStr := ANSWER_STRING; 196 | FSock.SendString('HTTP/1.0 200' + CRLF); 197 | FSock.SendString('Content-type: text/html'); 198 | FSock.SendString('Content-length: ' + IntToStr(Length(AnswerStr)) + CRLF); 199 | FSock.SendString('Date: ' + Rfc822DateTime(now) + CRLF); 200 | FSock.SendString('Connection: close' + CRLF); 201 | FSock.SendString('Server: syWebsocket Server' + CRLF); 202 | FSock.SendString('' + CRLF); 203 | FSock.SendString(AnswerStr); 204 | end; 205 | 206 | procedure TsyConnectedClient.SendHandShake(ASecWebSocketKey: string); 207 | var 208 | wsValue: string; 209 | sendStr: string; 210 | begin 211 | 212 | sendstr := 'HTTP/1.1 101 Web Socket Protocol Handshake' + CRLF; 213 | sendstr := sendstr + 'Server: syWebsocket Server' + CRLF; 214 | sendstr := sendstr + 'X-Powered-By: syWebSocket Server' + CRLF; 215 | sendstr := sendstr + 'Connection: Upgrade' + CRLF; 216 | 217 | 218 | 219 | wsValue := ASecWebSocketKey + '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'; 220 | wsvalue := MyEncodeBase64(SHA1String(wsValue)); 221 | 222 | sendstr := sendstr + 'Sec-WebSocket-Accept: ' + wsValue + CRLF; 223 | sendstr := sendstr + 'Upgrade: websocket' + CRLF; 224 | FSock.SendString(sendStr + CRLF); 225 | end; 226 | 227 | 228 | function TsyConnectedClient.GetWebSocketKey(AHeader: TStringList): string; 229 | var 230 | s: string; 231 | headerKey, headerValue: string; 232 | begin 233 | Result := ''; 234 | for s in AHeader do 235 | begin 236 | headerValue := s; 237 | headerKey := Fetch(headerValue, ':'); 238 | if headerKey = 'Sec-WebSocket-Key' then 239 | begin 240 | Result := headerValue; 241 | Exit; 242 | end; 243 | end; 244 | end; 245 | 246 | procedure TsyConnectedClient.ProcessData; 247 | var 248 | DataLen: integer; 249 | DataBuffer: TBytes; 250 | RcvLen: integer; 251 | RcvFrame: TMemoryStream; 252 | wsMessage: TsyWebSocketMessage; 253 | wsFrame: TsyBaseWebsocketFrame; 254 | //// 255 | tmp_s: string; 256 | begin 257 | // Websocket Loop 258 | FWebsocketFrame := TsyWebsockPackManager.Create(); 259 | wsMessage := TsyWebSocketMessage.Create; 260 | try 261 | while not Terminated do 262 | begin 263 | // get data from socket 264 | if FSock.CanRead(1000) then 265 | begin 266 | if Terminated then 267 | break; 268 | DataLen := FSock.WaitingData; 269 | if DataLen = 0 then 270 | exit; 271 | SetLength(DataBuffer, DataLen); 272 | if Terminated then 273 | break; 274 | 275 | RcvLen := FSock.RecvBuffer(@DataBuffer[0], DataLen); 276 | if RcvLen <> DataLen then // need raise exception 277 | Exit; 278 | FWebsocketFrame.InsertData(DataBuffer, RcvLen); 279 | 280 | while FWebsocketFrame.Count > 0 do 281 | begin 282 | RcvFrame := FWebsocketFrame.pop; 283 | 284 | wsFrame := TsyBaseWebsocketFrame.Create; 285 | try 286 | wsFrame.Frame := RcvFrame; 287 | 288 | // if set RSV1-RSV3 bit disconnect with error code 1002 289 | if wsFrame.Rsv1 or wsFrame.Rsv2 or wsFrame.Rsv3 then 290 | begin 291 | SendCloseFrame(1002, ''); 292 | Exit; 293 | end; 294 | 295 | if ((wsFrame.OpCode > optBinary) and (wsFrame.OpCode < optCloseConnect)) or (wsFrame.OpCode > optPong) then 296 | begin 297 | SendCloseFrame(1002, ''); 298 | Exit; 299 | end; 300 | 301 | 302 | case wsFrame.Opcode of 303 | optPing, optPong, optCloseConnect: // not fragmented frame 304 | begin 305 | case wsFrame.OpCode of 306 | optPing: 307 | begin 308 | if wsFrame.PayloadLen > 125 then // payload <=125 309 | begin 310 | SendCloseFrame(CLOSE_PROTOCOL_ERROR, ''); 311 | exit; 312 | end; 313 | if not wsFrame.Fin then // no fragmentation 314 | begin 315 | SendCloseFrame(CLOSE_PROTOCOL_ERROR, ''); 316 | exit; 317 | end; 318 | if Assigned(OnClientPing) then 319 | begin 320 | SendPong(wsFrame.MessageStr); 321 | OnClientPing(self, wsFrame.MessageStr); 322 | end; 323 | end; 324 | optPong: // we can not send ping. And if we get Pong we disconnect 325 | begin 326 | if not wsFrame.Fin then // no fragmentation 327 | begin 328 | SendCloseFrame(CLOSE_PROTOCOL_ERROR, ''); 329 | exit; 330 | end; 331 | end; 332 | optCloseConnect: 333 | begin 334 | if wsFrame.PayloadLen > 123 then 335 | begin 336 | SendCloseFrame(CLOSE_PROTOCOL_ERROR, ''); 337 | Exit; 338 | end; 339 | if wsFrame.PayloadLen > 2 then 340 | if not IsValidUTF8(@wsFrame.Binary[2], wsFrame.PayloadLen - 2) then 341 | begin 342 | SendCloseFrame(CLOSE_INVALID_FRAME_PAYLOAD_DATA, ''); 343 | exit; 344 | end; 345 | case wsFrame.Reason of 346 | 0..999, CLOSE_RESERVER, CLOSE_NO_STATUS_RCVD, CLOSE_ABNORMAL_CLOSURE, 347 | 1012..1014, CLOSE_TLS_HANDSHAKE, 1016..2999: 348 | SendCloseFrame(CLOSE_PROTOCOL_ERROR, ''); 349 | else 350 | begin 351 | SendCloseFrame(wsFrame.Reason, wsFrame.MessageStr); 352 | end; 353 | 354 | end; 355 | Exit; 356 | end; 357 | 358 | end; 359 | 360 | end; 361 | optText, optBinary, optContinue: // fragmented frame 362 | begin 363 | // Copy Payload data to TsyWebsocketMessage 364 | 365 | if not wsMessage.AddData(wsFrame) then 366 | exit; // critical error - Disconnect; 367 | // tmp_s := wsMessage.MessageStr; 368 | if wsMessage.IsReady then 369 | begin 370 | case wsMessage.MessageType of 371 | optText: // if Text then send OnClientTextMessage event to parent Thread about new Text message; 372 | begin 373 | if wsMessage.PayloadLen > 0 then // check valid UTF-8 string 374 | if not IsValidUTF8(@wsMessage.BinData[0], wsMessage.PayloadLen) then 375 | begin 376 | SendCloseFrame(CLOSE_INVALID_FRAME_PAYLOAD_DATA, ''); 377 | exit; 378 | end; 379 | if Assigned(OnClientTextMessage) then 380 | OnClientTextMessage(Self, wsMessage.MessageStr); 381 | 382 | end; 383 | optBinary: // if Text then send OnClientTextMessage event to parent Thread about new Binary message; 384 | if Assigned(OnClientBinaryData) then 385 | OnClientBinaryData(Self, wsMessage.BinData); 386 | end; 387 | end; 388 | 389 | end; 390 | end; 391 | finally 392 | FreeAndNil(wsFrame); 393 | end; 394 | end; 395 | 396 | SetLength(DataBuffer, 0); 397 | end; 398 | end; 399 | finally 400 | FreeAndNil(wsMessage); 401 | FreeAndNil(FWebsocketFrame); 402 | end; 403 | 404 | end; 405 | 406 | constructor TsyConnectedClient.Create(hSock: TSocket); 407 | begin 408 | InitCriticalSection(FCritSection); 409 | FTerminateEvent := RTLEventCreate; 410 | FSock := TTCPBlockSocket.Create; 411 | FSock.Socket := hSock; 412 | FreeOnTerminate := True; 413 | inherited Create(True); 414 | end; 415 | 416 | destructor TsyConnectedClient.Destroy; 417 | begin 418 | FreeAndNil(FSock); 419 | RTLeventdestroy(FTerminateEvent); 420 | DoneCriticalsection(FCritSection); 421 | inherited Destroy; 422 | end; 423 | 424 | procedure TsyConnectedClient.TerminateThread; 425 | begin 426 | if Terminated then 427 | exit; 428 | if Assigned(FSock) then 429 | FSock.CloseSocket; 430 | Terminate; 431 | 432 | RTLeventSetEvent(FTerminateEvent); 433 | 434 | end; 435 | 436 | procedure TsyConnectedClient.SendCloseFrame(AReason: integer; AMessage: string); 437 | var 438 | WFrame: TsyBaseWebsocketFrame; 439 | begin 440 | EnterCriticalsection(FCritSection); 441 | try 442 | if Terminated then 443 | exit; 444 | WFrame := TsyBaseWebsocketFrame.Create; 445 | try 446 | WFrame.Opcode := optCloseConnect; 447 | WFrame.Mask := False; 448 | WFrame.Reason := AReason; 449 | WFrame.MessageStr := AMessage; 450 | if FSock.CanWrite(1000) then 451 | FSock.SendBuffer(WFrame.Frame.Memory, WFrame.Frame.Size); 452 | finally 453 | FreeAndNil(WFrame); 454 | end; 455 | finally 456 | LeaveCriticalsection(FCritSection); 457 | end; 458 | TerminateThread; 459 | end; 460 | 461 | procedure TsyConnectedClient.SendMessageFrame(AMessage: string); 462 | var 463 | WFrame: TsyBaseWebsocketFrame; 464 | begin 465 | EnterCriticalsection(FCritSection); 466 | try 467 | if Terminated then 468 | Exit; 469 | WFrame := TsyBaseWebsocketFrame.Create; 470 | try 471 | WFrame.Opcode := optText; 472 | WFrame.Mask := False; 473 | WFrame.MessageStr := AMessage; 474 | try 475 | if FSock.CanWrite(1000) then 476 | FSock.SendBuffer(WFrame.Frame.Memory, WFrame.Frame.Size); 477 | except 478 | end; 479 | finally 480 | FreeAndNil(WFrame); 481 | end; 482 | finally 483 | LeaveCriticalsection(FCritSection); 484 | end; 485 | end; 486 | 487 | procedure TsyConnectedClient.SendBinaryFrame(ABinData: TBytes); 488 | var 489 | WFrame: TsyBaseWebsocketFrame; 490 | begin 491 | EnterCriticalsection(FCritSection); 492 | try 493 | if Terminated then 494 | Exit; 495 | WFrame := TsyBaseWebsocketFrame.Create; 496 | try 497 | WFrame.Fin := True; 498 | WFrame.Opcode := optBinary; 499 | WFrame.Mask := False; 500 | 501 | WFrame.Binary := ABinData; 502 | if FSock.CanWrite(1000) then 503 | FSock.SendBuffer(WFrame.Frame.Memory, WFrame.Frame.Size); 504 | finally 505 | FreeAndNil(WFrame); 506 | end; 507 | finally 508 | LeaveCriticalsection(FCritSection); 509 | end; 510 | end; 511 | 512 | procedure TsyConnectedClient.SendPong(AMessage: string); 513 | var 514 | WFrame: TsyBaseWebsocketFrame; 515 | begin 516 | EnterCriticalsection(FCritSection); 517 | try 518 | if Terminated then 519 | exit; 520 | WFrame := TsyBaseWebsocketFrame.Create; 521 | try 522 | WFrame.Opcode := optPong; 523 | WFrame.Mask := False; 524 | WFrame.MessageStr := AMessage; 525 | if FSock.CanWrite(1000) then 526 | FSock.SendBuffer(WFrame.Frame.Memory, WFrame.Frame.Size); 527 | finally 528 | FreeAndNil(WFrame); 529 | end; 530 | finally 531 | LeaveCriticalsection(FCritSection); 532 | end; 533 | end; 534 | 535 | procedure TsyConnectedClient.OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); 536 | begin 537 | if Terminated then 538 | exit; 539 | 540 | case Reason of 541 | HR_Error: 542 | Terminate; 543 | end; 544 | end; 545 | 546 | 547 | end. 548 | 549 | 550 | --------------------------------------------------------------------------------