/
websocket2.pas
1951 lines (1676 loc) · 60.9 KB
/
websocket2.pas
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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
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
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{==============================================================================|
| Project : Bauglir Internet Library |
|==============================================================================|
| Content: Generic connection and server |
|==============================================================================|
| Copyright (c)2011-2012, Bronislav Klucka |
| All rights reserved. |
| Source code is licenced under original 4-clause BSD licence: |
| http://licence.bauglir.com/bsd4.php |
| |
| |
| Project download homepage: |
| http://code.google.com/p/bauglir-websocket/ |
| Project homepage: |
| http://www.webnt.eu/index.php |
| WebSocket RFC: |
| http://tools.ietf.org/html/rfc6455 |
| |
| |
|==============================================================================|
| Requirements: Ararat Synapse (http://www.ararat.cz/synapse/) |
|==============================================================================}
{
2.0.4
1/ change: send generic frame SendData public on WSConnection
2/ pascal bugfix: closing connection issues (e.g. infinite sleep)
3/ add: server CloseAllConnections
4/ change: default client version 13 (RFC)
5/ pascal change: CanReceiveOrSend public
6/ pascal bugfix: events missing on erratic traffic
7/ add: make Handschake public property
@todo
* move writing to separate thread
* test for simultaneous i/o operations
http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-17
http://tools.ietf.org/html/rfc6455
http://dev.w3.org/html5/websockets/#refsFILEAPI
}
unit WebSocket2;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
interface
uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
Classes,
SysUtils,
blcksock,
CustomServer2,
syncobjs;
const
{:Constants section defining what kind of data are sent from one pont to another}
{:Continuation frame }
wsCodeContinuation = $0;
{:Text frame }
wsCodeText = $1;
{:Binary frame }
wsCodeBinary = $2;
{:Close frame }
wsCodeClose = $8;
{:Ping frame }
wsCodePing = $9;
{:Frame frame }
wsCodePong = $A;
{:Constants section defining close codes}
{:Normal valid closure, connection purpose was fulfilled}
wsCloseNormal = 1000;
{:Endpoint is going away (like server shutdown) }
wsCloseShutdown = 1001;
{:Protocol error }
wsCloseErrorProtocol = 1002;
{:Unknown frame data type or data type application cannot handle }
wsCloseErrorData = 1003;
{:Reserved }
wsCloseReserved1 = 1004;
{:Close received by peer but without any close code. This close code MUST NOT be sent by application. }
wsCloseNoStatus = 1005;
{:Abnotmal connection shutdown close code. This close code MUST NOT be sent by application. }
wsCloseErrorClose = 1006;
{:Received text data are not valid UTF-8. }
wsCloseErrorUTF8 = 1007;
{:Endpoint is terminating the connection because it has received a message that violates its policy. Generic error. }
wsCloseErrorPolicy = 1008;
{:Too large message received }
wsCloseTooLargeMessage = 1009;
{:Client is terminating the connection because it has expected the server to negotiate one or more extension, but the server didn't return them in the response message of the WebSocket handshake }
wsCloseClientExtensionError= 1010;
{:Server is terminating the connection because it encountered an unexpected condition that prevented it from fulfilling the request }
wsCloseErrorServerRequest = 1011;
{:Connection was closed due to a failure to perform a TLS handshake. This close code MUST NOT be sent by application. }
wsCloseErrorTLS = 1015;
type
TWebSocketCustomConnection = class;
{:Event procedural type to hook OnOpen events on connection
}
TWebSocketConnectionEvent = procedure (aSender: TWebSocketCustomConnection) of object;
{:Event procedural type to hook OnPing, OnPong events on connection
TWebSocketConnectionPingPongEvent = procedure (aSender: TWebSocketCustomConnection; aData: string) of object;
}
{:Event procedural type to hook OnClose event on connection
}
TWebSocketConnectionClose = procedure (aSender: TWebSocketCustomConnection; aCloseCode: integer; aCloseReason: string; aClosedByPeer: boolean) of object;
{:Event procedural type to hook OnRead on OnWrite event on connection
}
TWebSocketConnectionData = procedure (aSender: TWebSocketCustomConnection; aFinal, aRes1, aRes2, aRes3: boolean; aCode: integer; aData: TMemoryStream) of object;
{:Event procedural type to hook OnReadFull
}
TWebSocketConnectionDataFull = procedure (aSender: TWebSocketCustomConnection; aCode: integer; aData: TMemoryStream) of object;
{:abstract(WebSocket connection)
class is parent class for server and client connection
}
TWebSocketCustomConnection = class(TCustomConnection)
private
protected
fOnRead: TWebSocketConnectionData;
fOnReadFull: TWebSocketConnectionDataFull;
fOnWrite: TWebSocketConnectionData;
fOnClose: TWebSocketConnectionClose;
fOnOpen: TWebSocketConnectionEvent;
//fOnPing: TWebSocketConnectionPingPongEvent;
//fOnPong: TWebSocketConnectionPingPongEvent;
fCookie: string;
fVersion: integer;
fProtocol: string;
fResourceName: string;
fOrigin: string;
fExtension: string;
fPort: string;
fHost: string;
fHeaders: TStringList;
fClosedByMe: boolean;
fClosedByPeer: boolean;
fMasking: boolean;
fRequireMasking: boolean;
fHandshake: boolean;
fCloseCode: integer;
fCloseReason: string;
fClosingByPeer: boolean;
fReadFinal: boolean;
fReadRes1: boolean;
fReadRes2: boolean;
fReadRes3: boolean;
fReadCode: integer;
fReadStream: TMemoryStream;
fWriteFinal: boolean;
fWriteRes1: boolean;
fWriteRes2: boolean;
fWriteRes3: boolean;
fWriteCode: integer;
fWriteStream: TMemoryStream;
fSendCriticalSection: syncobjs.TCriticalSection;
fFullDataProcess: boolean;
fFullDataStream: TMemoryStream;
function GetClosed: boolean;
function GetClosing: boolean;
procedure ExecuteConnection; override;
function ReadData(var aFinal, aRes1, aRes2, aRes3: boolean; var aCode: integer; aData: TMemoryStream): integer; virtual;
function ValidConnection: boolean;
procedure DoSyncClose;
procedure DoSyncOpen;
//procedure DoSyncPing;
//procedure DoSyncPong;
procedure DoSyncRead;
procedure DoSyncReadFull;
procedure DoSyncWrite;
procedure SyncClose;
procedure SyncOpen;
//procedure SyncPing;
//procedure SyncPong;
procedure SyncRead;
procedure SyncReadFull;
procedure SyncWrite;
{:Overload this function to process connection close (not at socket level, but as an actual WebSocket frame)
aCloseCode represents close code (see wsClose constants)
aCloseReason represents textual information transfered with frame (there is no specified format or meaning)
aClosedByPeer whether connection has been closed by this connection object or by peer endpoint
}
procedure ProcessClose(aCloseCode: integer; aCloseReason: string; aClosedByPeer: boolean); virtual;
{:Overload this function to process data as soon as they are read before other Process<data> function is called
this function should be used by extensions to modify incomming data before the are process based on code
}
procedure ProcessData(var aFinal: boolean; var aRes1: boolean; var aRes2: boolean; var aRes3: boolean; var aCode: integer; aData: TMemoryStream); virtual;
{:Overload this function to process ping frame)
aData represents textual information transfered with frame (there is no specified format or meaning)
}
procedure ProcessPing(aData: string); virtual;
{:Overload this function to process pong frame)
aData represents textual information transfered with frame (there is no specified format or meaning)
}
procedure ProcessPong(aData: string); virtual;
{:Overload this function to process binary frame)
aFinal whether frame is final frame or continuing
aRes1 whether 1st extension bit is set up
aRes2 whether 2nd extension bit is set up
aRes3 whether 3rd extension bit is set up
aData data stream
second version is for contuniation frames
}
procedure ProcessStream(aFinal, aRes1, aRes2, aRes3: boolean; aData: TMemoryStream); virtual;
procedure ProcessStreamContinuation(aFinal, aRes1, aRes2, aRes3: boolean; aData: TMemoryStream); virtual;
procedure ProcessStreamFull(aData: TMemoryStream); virtual;
{:Overload this function to process text frame)
aFinal whether frame is final frame or continuing
aRes1 whether 1st extension bit is set up
aRes2 whether 2nd extension bit is set up
aRes3 whether 3rd extension bit is set up
aData textual data
second version is for contuniation frames
}
procedure ProcessText(aFinal, aRes1, aRes2, aRes3: boolean; aData: string); virtual;
procedure ProcessTextContinuation(aFinal, aRes1, aRes2, aRes3: boolean; aData: string); virtual;
procedure ProcessTextFull(aData: string); virtual;
published
public
constructor Create(aSocket: TTCPCustomConnectionSocket); override;
destructor Destroy; override;
{:
Whether connection is in active state (not closed, closing, socket, exists, i/o threads not terminated..)
}
function CanReceiveOrSend: boolean;
{:Procedure to close connection
aCloseCode represents close code (see wsClose constants)
aCloseReason represents textual information transfered with frame (there is no specified format or meaning) the string can only be 123 bytes length
}
procedure Close(aCode: integer; aCloseReason: string); virtual; abstract;
{:Send binary frame
aData data stream
aFinal whether frame is final frame or continuing
aRes1 1st extension bit
aRes2 2nd extension bit
aRes3 3rd extension bit
}
procedure SendBinary(aData: TStream; aFinal: boolean = true; aRes1: boolean = false; aRes2: boolean = false; aRes3: boolean = false);
{:Send binary continuation frame
aData data stream
aFinal whether frame is final frame or continuing
aRes1 1st extension bit
aRes2 2nd extension bit
aRes3 3rd extension bit
}
procedure SendBinaryContinuation(aData: TStream; aFinal: boolean = true; aRes1: boolean = false; aRes2: boolean = false; aRes3: boolean = false);
{:Send generic frame
aFinal whether frame is final frame or continuing
aRes1 1st extension bit
aRes2 2nd extension bit
aRes3 3rd extension bit
aCode frame code
aData data stream or string
}
function SendData(aFinal, aRes1, aRes2, aRes3: boolean; aCode: integer; aData: TStream): integer; overload; virtual;
function SendData(aFinal, aRes1, aRes2, aRes3: boolean; aCode: integer; aData: string): integer; overload; virtual;
{:Send textual frame
aData data string (MUST be UTF-8)
aFinal whether frame is final frame or continuing
aRes1 1st extension bit
aRes2 2nd extension bit
aRes3 3rd extension bit
}
procedure SendText(aData: string; aFinal: boolean = true; aRes1: boolean = false; aRes2: boolean = false; aRes3: boolean = false); virtual;
{:Send textual continuation frame
aData data string (MUST be UTF-8)
aFinal whether frame is final frame or continuing
aRes1 1st extension bit
aRes2 2nd extension bit
aRes3 3rd extension bit
}
procedure SendTextContinuation(aData: string; aFinal: boolean = true; aRes1: boolean = false; aRes2: boolean = false; aRes3: boolean = false);
{:Send Ping
aData ping informations
}
procedure Ping(aData: string);
{:Send Pong
aData pong informations
}
procedure Pong(aData: string);
{:Temination procedure
This method should be called instead of Terminate to terminate thread,
it internally calls Terminate, but can be overloaded,
and can be used for data clean up
}
procedure TerminateThread; override;
{: Whether connection has been closed
(either socket has been closed or thread has been terminated or WebSocket has been closed by this and peer connection)
}
property Closed: boolean read GetClosed;
{: Whether WebSocket has been closed by this and peer connection }
property Closing: boolean read GetClosing;
{: WebSocket connection cookies
Property is regular unparsed Cookie header string
e.g. cookie1=value1;cookie2=value2
empty string represents that no cookies are present
}
property Cookie: string read fCookie;
{: WebSocket connection extensions
Property is regular unparsed Sec-WebSocket-Extensions header string
e.g. foo, bar; baz=2
On both client and server connection this value represents the extension(s) selected by server to be used
as a result of extension negotioation
value - represents that no extension was negotiated and no header will be sent to client
it is the default value
}
property Extension: string read fExtension;
{:Whether to register for full data processing
(callink @link(ProcessFullText), @link(ProcessFullStream) @link(OnFullRead)
those methods/events are called if FullDataProcess is @true and whole message is read (after final frame)
}
property FullDataProcess: boolean read fFullDataProcess write fFullDataProcess;
{:
Whether WebSocket handshake was succecfull (and connection is afer WS handshake)
}
property Handshake: boolean read fHandshake;
{: WebSocket connection host
Property is regular unparsed Host header string
e.g. server.example.com
}
property Host: string read fHost;
{: WebSocket connection origin
Property is regular unparsed Sec-WebSocket-Origin header string
e.g. http://example.com
}
property Origin: string read fOrigin;
{: WebSocket connection protocol
Property is regular unparsed Sec-WebSocket-Protocol header string
e.g. chat, superchat
On both client and server connection this value represents the protocol(s) selected by server to be used
as a result of protocol negotioation
value - represents that no protocol was negotiated and no header will be sent to client
it is the default value
}
property Protocol: string read fProtocol;
{: Connection port }
property Port: string read fPort;
{: Connection resource
e.g. /path1/path2/path3/file.ext
}
property ResourceName: string read fResourceName;
{: WebSocket version (either 7 or 8 or 13)}
property Version: integer read fVersion;
{: WebSocket Close frame event }
property OnClose: TWebSocketConnectionClose read fOnClose write fOnClose;
{: WebSocket connection successfully }
property OnOpen: TWebSocketConnectionEvent read fOnOpen write fOnOpen;
{ : WebSocket ping
property OnPing: TWebSocketConnectionPingPongEvent read fOnPing write fOnPing;
}
{ : WebSocket pong
property OnPong: TWebSocketConnectionPingPongEvent read fOnPong write fOnPong;
}
{: WebSocket frame read }
property OnRead: TWebSocketConnectionData read fOnRead write fOnRead;
{: WebSocket read full data}
property OnReadFull: TWebSocketConnectionDataFull read fOnReadFull write fOnReadFull;
{: WebSocket frame written }
property OnWrite: TWebSocketConnectionData read fOnWrite write fOnWrite;
end;
{: Class of WebSocket connections }
TWebSocketCustomConnections = class of TWebSocketCustomConnection;
{: WebSocket server connection automatically created by server on incoming connection }
TWebSocketServerConnection = class(TWebSocketCustomConnection)
public
constructor Create(aSocket: TTCPCustomConnectionSocket); override;
procedure Close(aCode: integer; aCloseReason: string); override;
procedure TerminateThread; override;
{: List of all headers
keys are lowercased header name
e.g host, connection, sec-websocket-key
}
property Header: TStringList read fHeaders;
end;
{: Class of WebSocket server connections }
TWebSocketServerConnections = class of TWebSocketServerConnection;
{: WebSocket client connection, this object shoud be created to establish client to server connection }
TWebSocketClientConnection = class(TWebSocketCustomConnection)
protected
function BeforeExecuteConnection: boolean; override;
public
{: construstor to create connection,
parameters has the same meaning as corresponging connection properties (see 2 differences below) and
should be formated according to headers values
aProtocol and aExtension in constructor represents protocol(s) and extension(s)
client is trying to negotiate, obejst properties then represents
protocol(s) and extension(s) the server is supporting (the negotiation result)
Version must be >= 8
}
constructor Create(aHost, aPort, aResourceName: string;
aOrigin: string = '-'; aProtocol: string = '-'; aExtension: string = '-';
aCookie: string = '-'; aVersion: integer = 13); reintroduce; virtual;
procedure Close(aCode: integer; aCloseReason: string); override;
procedure Execute; override;
end;
TWebSocketServer = class;
{:Event procedural type to hook OnReceiveConnection events on server
every time new server connection is about to be created (client is connecting to server)
this event is called
properties are representing connection properties as defined in @link(TWebSocketServerConnection)
Protocol and Extension represents corresponding headers sent by client, as their out value
server must define what kind of protocol(s) and extension(s) server is supporting, if event
is not implemented, both values are considered as - (no value at all)
HttpResult represents the HTTP result to be send in response, if connection is about to be
accepted, the value MUST BE 101, any other value meand that the client will be informed about the
result (using the HTTP code meaning) and connection will be closed, if event is not implemented
101 is used as a default value
}
TWebSocketServerReceiveConnection = procedure (
Server: TWebSocketServer; Socket: TTCPCustomConnectionSocket;
Header: TStringList;
ResourceName, Host, Port, Origin, Cookie: string;
HttpResult: integer;
Protocol, Extensions: string
) of object;
TWebSocketServer = class(TCustomServer)
protected
{CreateServerConnection sync variables}
fncSocket: TTCPCustomConnectionSocket;
fncResourceName: string;
fncHost: string;
fncPort: string;
fncOrigin: string;
fncProtocol: string;
fncExtensions: string;
fncCookie: string;
fncHeaders: string;
fncResultHttp: integer;
fOnReceiveConnection: TWebSocketServerReceiveConnection; protected
function CreateServerConnection(aSocket: TTCPCustomConnectionSocket): TCustomConnection; override;
procedure DoSyncReceiveConnection;
procedure SyncReceiveConnection;
property Terminated;
{:This function defines what kind of TWebSocketServerConnection implementation should be used as
a connection object.
The servers default return value is TWebSocketServerConnection.
If new connection class based on TWebSocketServerConnection is implemented,
new server should be implemented as well with this method overloaded
properties are representing connection properties as defined in @link(TWebSocketServerConnection)
Protocol and Extension represents corresponding headers sent by client, as their out value
server must define what kind of protocol(s) and extension(s) server is supporting, if event
is not implemented, both values are cosidered as - (no value at all)
HttpResult represents the HTTP result to be send in response, if connection is about to be
accepted, the value MUST BE 101, any other value meand that the client will be informed about the
result (using the HTTP code meaning) and connection will be closed, if event is not implemented
101 is used as a default value
}
function GetWebSocketConnectionClass(
Socket: TTCPCustomConnectionSocket;
Header: TStringList;
ResourceName, Host, Port, Origin, Cookie: string;
out HttpResult: integer;
var Protocol, Extensions: string
): TWebSocketServerConnections; virtual;
public
{: WebSocket connection received }
property OnReceiveConnection: TWebSocketServerReceiveConnection read fOnReceiveConnection write fOnReceiveConnection;
{: close all connections
for parameters see connection Close method
}
procedure CloseAllConnections(aCloseCode: integer; aReason: string);
{:Temination procedure
This method should be called instead of Terminate to terminate thread,
it internally calls Terminate, but can be overloaded,
and can be used for data clean up
}
procedure TerminateThread; override;
{: Method to send binary data to all connected clients
see @link(TWebSocketServerConnection.SendBinary) for parameters description
}
procedure BroadcastBinary(aData: TStream; aFinal: boolean = true; aRes1: boolean = false; aRes2: boolean = false; aRes3: boolean = false);
{: Method to send text data to all connected clients
see @link(TWebSocketServerConnection.SendText) for parameters description
}
procedure BroadcastText(aData: string; aFinal: boolean = true; aRes1: boolean = false; aRes2: boolean = false; aRes3: boolean = false);
end;
function httpCode(code: integer): string;
implementation
uses Math, synautil, synacode, synsock {$IFDEF Win32}, Windows{$ENDIF Win32},
BClasses, synachar;
{$IFDEF Win32} {$O-} {$ENDIF Win32}
function httpCode(code: integer): string;
begin
case (code) of
100: result := 'Continue';
101: result := 'Switching Protocols';
200: result := 'OK';
201: result := 'Created';
202: result := 'Accepted';
203: result := 'Non-Authoritative Information';
204: result := 'No Content';
205: result := 'Reset Content';
206: result := 'Partial Content';
300: result := 'Multiple Choices';
301: result := 'Moved Permanently';
302: result := 'Found';
303: result := 'See Other';
304: result := 'Not Modified';
305: result := 'Use Proxy';
307: result := 'Temporary Redirect';
400: result := 'Bad Request';
401: result := 'Unauthorized';
402: result := 'Payment Required';
403: result := 'Forbidden';
404: result := 'Not Found';
405: result := 'Method Not Allowed';
406: result := 'Not Acceptable';
407: result := 'Proxy Authentication Required';
408: result := 'Request Time-out';
409: result := 'Conflict';
410: result := 'Gone';
411: result := 'Length Required';
412: result := 'Precondition Failed';
413: result := 'Request Entity Too Large';
414: result := 'Request-URI Too Large';
415: result := 'Unsupported Media Type';
416: result := 'Requested range not satisfiable';
417: result := 'Expectation Failed';
500: result := 'Internal Server Error';
501: result := 'Not Implemented';
502: result := 'Bad Gateway';
503: result := 'Service Unavailable';
504: result := 'Gateway Time-out';
else result := 'unknown code: $code';
end;
end;
function ReadHttpHeaders(aSocket: TTCPCustomConnectionSocket; var aGet: string; aHeaders: TStrings): boolean;
var s, name: string;
begin
aGet := '';
aHeaders.Clear;
result := true;
repeat
aSocket.MaxLineLength := 1024 * 1024; // not to attack memory on server
s := aSocket.RecvString(30 * 1000); // not to hang up connection
if (aSocket.LastError <> 0) then
begin
result := false;
break;
end;
if (s = '') then
break;
if (aGet = '') then
aGet := s
else
begin
name := LowerCase(trim(SeparateLeft(s, ':')));
if (aHeaders.Values[name] = '') then
aHeaders.Values[name] := trim(SeparateRight(s, ':'))
else
aHeaders.Values[name] := aHeaders.Values[name] + ',' + trim(SeparateRight(s, ':'));
end;
until {IsTerminated} false;
aSocket.MaxLineLength := 0;
end;
procedure ODS(aStr: string); overload;
begin
{$IFDEF Win32}
OutputDebugString(pChar(FormatDateTime('yyyy-mm-dd hh:nn:ss', now) + ': ' + aStr));
{$ENDIF Win32}
end;
procedure ODS(aStr: string; aData: array of const); overload;
begin
{$IFDEF Win32}
ODS(Format(aStr, aData));
{$ENDIF Win32}
end;
{ TWebSocketServer }
procedure TWebSocketServer.BroadcastBinary(aData: TStream; aFinal: boolean = true; aRes1: boolean = false; aRes2: boolean = false; aRes3: boolean = false);
var i: integer;
begin
LockTermination;
for i := 0 to fConnections.Count - 1 do
begin
if (not TWebSocketServerConnection(fConnections[i]).IsTerminated) then
TWebSocketServerConnection(fConnections[i]).SendBinary(aData, aFinal, aRes1, aRes2, aRes3);
end;
UnLockTermination;
end;
procedure TWebSocketServer.BroadcastText(aData: string; aFinal: boolean = true; aRes1: boolean = false; aRes2: boolean = false; aRes3: boolean = false);
var i: integer;
begin
LockTermination;
for i := 0 to fConnections.Count - 1 do
begin
if (not TWebSocketServerConnection(fConnections[i]).IsTerminated) then
TWebSocketServerConnection(fConnections[i]).SendText(aData, aFinal, aRes1, aRes2, aRes3);
end;
UnLockTermination;
end;
procedure TWebSocketServer.CloseAllConnections(aCloseCode: integer; aReason: string);
var i: integer;
begin
LockTermination;
//for i := 0 to fConnections.Count - 1 do
for i := fConnections.Count - 1 downto 0 do
begin
if (not TWebSocketServerConnection(fConnections[i]).IsTerminated) then
TWebSocketServerConnection(fConnections[i]).Close(aCloseCode, aReason);// SendBinary(aData, aFinal, aRes1, aRes2, aRes3);
end;
UnLockTermination;
end;
function TWebSocketServer.CreateServerConnection(aSocket: TTCPCustomConnectionSocket): TCustomConnection;
var headers, hrs: TStringList;
get: string;
s{, resName, host, port}, key, version{, origin, protocol, extensions, cookie}: string;
iversion, vv: integer;
res: boolean;
r : TWebSocketServerConnections;
begin
fncSocket := aSocket;
result := inherited CreateServerConnection(aSocket);
headers := TStringList.Create;
try
res := ReadHttpHeaders(aSocket, get, headers);
if (res) then
begin
res := false;
try
//CHECK HTTP GET
if ((Pos('GET ', Uppercase(get)) <> 0) and (Pos(' HTTP/1.1', Uppercase(get)) <> 0)) then
begin
fncResourceName := SeparateRight(get, ' ');
fncResourceName := SeparateLeft(fncResourceName, ' ');
end
else exit;
fncResourceName := trim(fncResourceName);
//CHECK HOST AND PORT
s := headers.Values['host'];
if (s <> '') then
begin
fncHost := trim(s);
fncPort := SeparateRight(fncHost, ':');
fncHost := SeparateLeft(fncHost, ':');
end;
fncHost := trim(fncHost);
fncPort := trim(fncPort);
if (fncHost = '') then exit;
//if (fncPort <> '') and (fncPort <> self.port) then exit;
{
if (self.host <> '0.0.0.0') and (self.Host <> '127.0.0.1') and
(self.host <> 'localhost') and (fncHost <> self.host) then exit;
}
//WEBSOCKET KEY
s := headers.Values['sec-websocket-key'];
if (s <> '') then
begin
if (Length(DecodeBase64(s)) = 16) then
begin
key := s;
end;
end;
if (key = '') then exit;
key := trim(key);
//WEBSOCKET VERSION
s := headers.Values['sec-websocket-version'];
if (s <> '') then
begin
vv := StrToIntDef(s, -1);
if ((vv >= 7) and (vv <= 13)) then
begin
version := s;
end;
end;
if (version = '') then exit;
version := trim(version);
iversion := StrToIntDef(version, 13);
if (LowerCase(headers.Values['upgrade']) <> LowerCase('websocket')) or (pos('upgrade', LowerCase(headers.Values['connection'])) = 0) then
exit;
//COOKIES
fncProtocol := '-';
fncExtensions := '-';
fncCookie := '-';
fncOrigin := '-';
if (iversion < 13) then
begin
if (headers.IndexOfName('sec-websocket-origin') > -1) then
fncOrigin := trim(headers.Values['sec-websocket-origin']);
end
else
begin
if (headers.IndexOfName('origin') > -1) then
fncOrigin := trim(headers.Values['origin']);
end;
if (headers.IndexOfName('sec-websocket-protocol') > -1) then
fncProtocol := trim(headers.Values['sec-websocket-protocol']);
if (headers.IndexOfName('sec-websocket-extensions') > -1) then
fncExtensions := trim(headers.Values['sec-websocket-extensions']);
if (headers.IndexOfName('cookie') > -1) then
fncCookie := trim(headers.Values['cookie']);
fncHeaders := trim(headers.text);
res := true;
finally
if (res) then
begin
fncResultHttp := 101;
hrs := TStringList.Create;
hrs.Assign(headers);
r := GetWebSocketConnectionClass(
fncSocket,
hrs,
fncResourceName, fncHost, fncPort, fncOrigin, fncCookie,
fncResultHttp, fncProtocol, fncExtensions
);
if (assigned(r)) then
begin
DoSyncReceiveConnection;
if (fncResultHttp <> 101) then //HTTP ERROR FALLBACK
begin
aSocket.SendString(Format('HTTP/1.1 %d %s'+#13#10, [fncResultHttp, httpCode(fncResultHttp)]));
aSocket.SendString(Format('%d %s'+#13#10#13#10, [fncResultHttp, httpCode(fncResultHttp)]));
end
else
begin
key := EncodeBase64(SHA1(key + '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'));
s := 'HTTP/1.1 101 Switching Protocols' + #13#10;
s := s + 'Upgrade: websocket' + #13#10;
s := s + 'Connection: Upgrade' + #13#10;
s := s + 'Sec-WebSocket-Accept: ' + key + #13#10;
if (fncProtocol <> '-') then
begin
s := s + 'Sec-WebSocket-Protocol: ' + fncProtocol + #13#10;
end;
// Commenting this out fixed errors.
// if (fncExtensions <> '-') then
// begin
// s := s + 'Sec-WebSocket-Extensions: ' + fncExtensions + #13#10;
// end;
s := s + #13#10;
aSocket.SendString(s);
if (aSocket.LastError = 0) then
begin
result := r.Create(aSocket);
TWebSocketCustomConnection(result).fCookie := fncCookie;
TWebSocketCustomConnection(result).fVersion := StrToInt(version);
TWebSocketCustomConnection(result).fProtocol := fncProtocol;
TWebSocketCustomConnection(result).fResourceName := fncResourceName;
TWebSocketCustomConnection(result).fOrigin := fncOrigin;
TWebSocketCustomConnection(result).fExtension := fncExtensions;
TWebSocketCustomConnection(result).fPort := fncPort;
TWebSocketCustomConnection(result).fHost := fncHost;
TWebSocketCustomConnection(result).fHeaders.Assign(headers);
TWebSocketCustomConnection(result).fHandshake := true;
end;
end;
end;
hrs.Free;
end;
end;
end;
finally
headers.Free;
end;
end;
procedure TWebSocketServer.DoSyncReceiveConnection;
begin
if (assigned(fOnReceiveConnection)) then
Synchronize(SyncReceiveConnection)
end;
function TWebSocketServer.GetWebSocketConnectionClass( Socket: TTCPCustomConnectionSocket;
Header: TStringList;
ResourceName, Host, Port, Origin, Cookie: string;
out HttpResult: integer;
var Protocol, Extensions: string
): TWebSocketServerConnections;
begin
result := TWebSocketServerConnection;
end;
procedure TWebSocketServer.SyncReceiveConnection;
var h: TStringList;
begin
if (assigned(fOnReceiveConnection)) then
begin
h := TStringList.Create;
h.Text := fncHeaders;
fOnReceiveConnection(
self, fncSocket,
h,
fncResourceName, fncHost, fncPort, fncOrigin, fncCookie,
fncResultHttp, fncProtocol, fncExtensions
);
h.Free;
end;
end;
procedure TWebSocketServer.TerminateThread;
begin
if (terminated) then exit;
fOnReceiveConnection := nil;
inherited;
end;
{ TWebSocketCustomConnection }
function TWebSocketCustomConnection.CanReceiveOrSend: boolean;
begin
result := ValidConnection and not (fClosedByMe or fClosedByPeer) and fHandshake;
end;
constructor TWebSocketCustomConnection.Create(aSocket: TTCPCustomConnectionSocket);
begin
fHeaders := TStringList.Create;
fCookie := '';
fVersion := 0;
fProtocol := '-';
fResourceName := '';
fOrigin := '';
fExtension := '-';
fPort := '';
fHost := '';
fClosedByMe := false;
fClosedByPeer := false;
fMasking := false;
fClosingByPeer := false;
fRequireMasking := false;
fReadFinal := false;
fReadRes1 := false;
fReadRes2 := false;
fReadRes3 := false;
fReadCode := 0;
fReadStream := TMemoryStream.Create;
fWriteFinal := false;
fWriteRes1 := false;
fWriteRes2 := false;
fWriteRes3 := false;
fWriteCode := 0;
fWriteStream := TMemoryStream.Create;
fFullDataProcess := false;
fFullDataStream := TMemoryStream.Create;
fSendCriticalSection := syncobjs.TCriticalSection.Create;
fHandshake := false;
inherited;
end;
destructor TWebSocketCustomConnection.Destroy;
begin