1 {==============================================================================|
2 | Project : Ararat Synapse | 009.010.000 |
3 |==============================================================================|
4 | Content: Library base |
5 |==============================================================================|
6 | Copyright (c)1999-2017, Lukas Gebauer |
7 | All rights reserved. |
8 | |
9 | Redistribution and use in source and binary forms, with or without |
10 | modification, are permitted provided that the following conditions are met: |
11 | |
12 | Redistributions of source code must retain the above copyright notice, this |
13 | list of conditions and the following disclaimer. |
14 | |
15 | Redistributions in binary form must reproduce the above copyright notice, |
16 | this list of conditions and the following disclaimer in the documentation |
17 | and/or other materials provided with the distribution. |
18 | |
19 | Neither the name of Lukas Gebauer nor the names of its contributors may |
20 | be used to endorse or promote products derived from this software without |
21 | specific prior written permission. |
22 | |
23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
24 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
25 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
26 | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
27 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
28 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
29 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
30 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
31 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
32 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
33 | DAMAGE. |
34 |==============================================================================|
35 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36 | Portions created by Lukas Gebauer are Copyright (c)1999-2017. |
37 | All Rights Reserved. |
38 |==============================================================================|
39 | Contributor(s): |
40 |==============================================================================|
41 | History: see HISTORY.HTM from distribution package |
42 | (Found at URL: http://www.ararat.cz/synapse/) |
43 |==============================================================================}
44
45 {
46 Special thanks to Gregor Ibic <gregor.ibic@intelicom.si>
47 (Intelicom d.o.o., http://www.intelicom.si)
48 for good inspiration about SSL programming.
49 }
50
51 {$DEFINE ONCEWINSOCK}
52 {Note about define ONCEWINSOCK:
53 If you remove this compiler directive, then socket interface is loaded and
54 initialized on constructor of TBlockSocket class for each socket separately.
55 Socket interface is used only if your need it.
56
57 If you leave this directive here, then socket interface is loaded and
58 initialized only once at start of your program! It boost performace on high
59 count of created and destroyed sockets. It eliminate possible small resource
60 leak on Windows systems too.
61 }
62
63 //{$DEFINE RAISEEXCEPT}
64 {When you enable this define, then is Raiseexcept property is on by default
65 }
66
67 {:@abstract(Synapse's library core)
68
69 Core with implementation basic socket classes.
70 }
71
72 {$IFDEF FPC}
73 {$MODE DELPHI}
74 {$ENDIF}
75 {$IFDEF VER125}
76 {$DEFINE BCB}
77 {$ENDIF}
78 {$IFDEF BCB}
79 {$ObjExportAll On}
80 {$ENDIF}
81 {$Q-}
82 {$H+}
83 {$M+}
84 {$TYPEDADDRESS OFF}
85
86
87 //old Delphi does not have MSWINDOWS define.
88 {$IFDEF WIN32}
89 {$IFNDEF MSWINDOWS}
90 {$DEFINE MSWINDOWS}
91 {$ENDIF}
92 {$ENDIF}
93
94 {$IFDEF UNICODE}
95 {$WARN IMPLICIT_STRING_CAST OFF}
96 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
97 {$ENDIF}
98
99 unit blcksock;
100
101 interface
102
103 uses
104 SysUtils, Classes,
105 synafpc,
106 synsock, synautil, synacode, synaip
107 {$IFDEF CIL}
108 ,System.Net
109 ,System.Net.Sockets
110 ,System.Text
111 {$ENDIF}
112 ;
113
114 const
115
116 SynapseRelease = '40';
117
118 cLocalhost = '127.0.0.1';
119 cAnyHost = '0.0.0.0';
120 cBroadcast = '255.255.255.255';
121 c6Localhost = '::1';
122 c6AnyHost = '::0';
123 c6Broadcast = 'ffff::1';
124 cAnyPort = '0';
125 CR = #$0d;
126 LF = #$0a;
127 CRLF = CR + LF;
128 c64k = 65536;
129
130 type
131
132 {:@abstract(Exception clas used by Synapse)
133 When you enable generating of exceptions, this exception is raised by
134 Synapse's units.}
135 ESynapseError = class(Exception)
136 private
137 FErrorCode: Integer;
138 FErrorMessage: string;
139 published
140 {:Code of error. Value depending on used operating system}
141 property ErrorCode: Integer read FErrorCode Write FErrorCode;
142 {:Human readable description of error.}
143 property ErrorMessage: string read FErrorMessage Write FErrorMessage;
144 end;
145
146 {:Types of OnStatus events}
147 THookSocketReason = (
148 {:Resolving is begin. Resolved IP and port is in parameter in format like:
149 'localhost.somewhere.com:25'.}
150 HR_ResolvingBegin,
151 {:Resolving is done. Resolved IP and port is in parameter in format like:
152 'localhost.somewhere.com:25'. It is always same as in HR_ResolvingBegin!}
153 HR_ResolvingEnd,
154 {:Socket created by CreateSocket method. It reporting Family of created
155 socket too!}
156 HR_SocketCreate,
157 {:Socket closed by CloseSocket method.}
158 HR_SocketClose,
159 {:Socket binded to IP and Port. Binded IP and Port is in parameter in format
160 like: 'localhost.somewhere.com:25'.}
161 HR_Bind,
162 {:Socket connected to IP and Port. Connected IP and Port is in parameter in
163 format like: 'localhost.somewhere.com:25'.}
164 HR_Connect,
165 {:Called when CanRead method is used with @True result.}
166 HR_CanRead,
167 {:Called when CanWrite method is used with @True result.}
168 HR_CanWrite,
169 {:Socket is swithed to Listen mode. (TCP socket only)}
170 HR_Listen,
171 {:Socket Accepting client connection. (TCP socket only)}
172 HR_Accept,
173 {:report count of bytes readed from socket. Number is in parameter string.
174 If you need is in integer, you must use StrToInt function!}
175 HR_ReadCount,
176 {:report count of bytes writed to socket. Number is in parameter string. If
177 you need is in integer, you must use StrToInt function!}
178 HR_WriteCount,
179 {:If is limiting of bandwidth on, then this reason is called when sending or
180 receiving is stopped for satisfy bandwidth limit. Parameter is count of
181 waiting milliseconds.}
182 HR_Wait,
183 {:report situation where communication error occured. When raiseexcept is
184 @true, then exception is called after this Hook reason.}
185 HR_Error
186 );
187
188 {:Procedural type for OnStatus event. Sender is calling TBlockSocket object,
189 Reason is one of set Status events and value is optional data.}
190 THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason;
191 const Value: String) of object;
192
193 {:This procedural type is used for DataFilter hooks.}
194 THookDataFilter = procedure(Sender: TObject; var Value: AnsiString) of object;
195
196 {:This procedural type is used for hook OnCreateSocket. By this hook you can
197 insert your code after initialisation of socket. (you can set special socket
198 options, etc.)}
199 THookCreateSocket = procedure(Sender: TObject) of object;
200
201 {:This procedural type is used for monitoring of communication.}
202 THookMonitor = procedure(Sender: TObject; Writing: Boolean;
203 const Buffer: TMemory; Len: Integer) of object;
204
205 {:This procedural type is used for hook OnAfterConnect. By this hook you can
206 insert your code after TCP socket has been sucessfully connected.}
207 THookAfterConnect = procedure(Sender: TObject) of object;
208
209 {:This procedural type is used for hook OnVerifyCert. By this hook you can
210 insert your additional certificate verification code. Usefull to verify server
211 CN against URL. }
212
endernull213 THookVerifyCert = function(Sender: TObject):boolean of object;
214
215 {:This procedural type is used for hook OnHeartbeat. By this hook you can
216 call your code repeately during long socket operations.
217 You must enable heartbeats by @Link(HeartbeatRate) property!}
218 THookHeartbeat = procedure(Sender: TObject) of object;
219
220 {:Specify family of socket.}
221 TSocketFamily = (
222 {:Default mode. Socket family is defined by target address for connection.
223 It allows instant access to IPv4 and IPv6 nodes. When you need IPv6 address
224 as destination, then is used IPv6 mode. othervise is used IPv4 mode.
225 However this mode not working properly with preliminary IPv6 supports!}
226 SF_Any,
227 {:Turn this class to pure IPv4 mode. This mode is totally compatible with
228 previous Synapse releases.}
229 SF_IP4,
230 {:Turn to only IPv6 mode.}
231 SF_IP6
232 );
233
234 {:specify possible values of SOCKS modes.}
235 TSocksType = (
236 ST_Socks5,
237 ST_Socks4
238 );
239
240 {:Specify requested SSL/TLS version for secure connection.}
241 TSSLType = (
242 LT_all,
243 LT_SSLv2,
244 LT_SSLv3,
245 LT_TLSv1,
246 LT_TLSv1_1,
247 LT_TLSv1_2,
248 LT_SSHv2
249 );
250
251 {:Specify type of socket delayed option.}
252 TSynaOptionType = (
253 SOT_Linger,
254 SOT_RecvBuff,
255 SOT_SendBuff,
256 SOT_NonBlock,
257 SOT_RecvTimeout,
258 SOT_SendTimeout,
259 SOT_Reuse,
260 SOT_TTL,
261 SOT_Broadcast,
262 SOT_MulticastTTL,
263 SOT_MulticastLoop
264 );
265
266 {:@abstract(this object is used for remember delayed socket option set.)}
267 TSynaOption = class(TObject)
268 public
269 Option: TSynaOptionType;
270 Enabled: Boolean;
271 Value: Integer;
272 end;
273
274 TCustomSSL = class;
275 TSSLClass = class of TCustomSSL;
276
277 {:@abstract(Basic IP object.)
278 This is parent class for other class with protocol implementations. Do not
279 use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket),
280 @link(TTCPBlockSocket) or @link(TUDPBlockSocket) instead.}
281 TBlockSocket = class(TObject)
282 private
283 FOnStatus: THookSocketStatus;
284 FOnReadFilter: THookDataFilter;
285 FOnCreateSocket: THookCreateSocket;
286 FOnMonitor: THookMonitor;
287 FOnHeartbeat: THookHeartbeat;
288 FLocalSin: TVarSin;
289 FRemoteSin: TVarSin;
290 FTag: integer;
291 FBuffer: AnsiString;
292 FRaiseExcept: Boolean;
293 FNonBlockMode: Boolean;
294 FMaxLineLength: Integer;
295 FMaxSendBandwidth: Integer;
296 FNextSend: LongWord;
297 FMaxRecvBandwidth: Integer;
298 FNextRecv: LongWord;
299 FConvertLineEnd: Boolean;
300 FLastCR: Boolean;
301 FLastLF: Boolean;
302 FBinded: Boolean;
303 FFamily: TSocketFamily;
304 FFamilySave: TSocketFamily;
305 FIP6used: Boolean;
306 FPreferIP4: Boolean;
307 FDelayedOptions: TList;
308 FInterPacketTimeout: Boolean;
309 {$IFNDEF CIL}
310 FFDSet: TFDSet;
311 {$ENDIF}
312 FRecvCounter: Integer;
313 FSendCounter: Integer;
314 FSendMaxChunk: Integer;
315 FStopFlag: Boolean;
316 FNonblockSendTimeout: Integer;
317 FHeartbeatRate: integer;
318 FConnectionTimeout: integer;
319 {$IFNDEF ONCEWINSOCK}
320 FWsaDataOnce: TWSADATA;
321 {$ENDIF}
GetSizeRecvBuffernull322 function GetSizeRecvBuffer: Integer;
323 procedure SetSizeRecvBuffer(Size: Integer);
GetSizeSendBuffernull324 function GetSizeSendBuffer: Integer;
325 procedure SetSizeSendBuffer(Size: Integer);
326 procedure SetNonBlockMode(Value: Boolean);
327 procedure SetTTL(TTL: integer);
GetTTLnull328 function GetTTL:integer;
329 procedure SetFamily(Value: TSocketFamily); virtual;
330 procedure SetSocket(Value: TSocket); virtual;
GetWsaDatanull331 function GetWsaData: TWSAData;
FamilyToAFnull332 function FamilyToAF(f: TSocketFamily): TAddrFamily;
333 protected
334 FSocket: TSocket;
335 FLastError: Integer;
336 FLastErrorDesc: string;
337 FOwner: TObject;
338 procedure SetDelayedOption(const Value: TSynaOption);
339 procedure DelayedOption(const Value: TSynaOption);
340 procedure ProcessDelayedOptions;
341 procedure InternalCreateSocket(Sin: TVarSin);
342 procedure SetSin(var Sin: TVarSin; IP, Port: string);
GetSinIPnull343 function GetSinIP(Sin: TVarSin): string;
GetSinPortnull344 function GetSinPort(Sin: TVarSin): Integer;
345 procedure DoStatus(Reason: THookSocketReason; const Value: string);
346 procedure DoReadFilter(Buffer: TMemory; var Len: Integer);
347 procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
348 procedure DoCreateSocket;
349 procedure DoHeartbeat;
350 procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
351 procedure SetBandwidth(Value: Integer);
TestStopFlagnull352 function TestStopFlag: Boolean;
353 procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual;
InternalCanReadnull354 function InternalCanRead(Timeout: Integer): Boolean; virtual;
InternalCanWritenull355 function InternalCanWrite(Timeout: Integer): Boolean; virtual;
356 public
357 constructor Create;
358
359 {:Create object and load all necessary socket library. What library is
360 loaded is described by STUB parameter. If STUB is empty string, then is
361 loaded default libraries.}
362 constructor CreateAlternate(Stub: string);
363 destructor Destroy; override;
364
365 {:If @link(family) is not SF_Any, then create socket with type defined in
366 @link(Family) property. If family is SF_Any, then do nothing! (socket is
367 created automaticly when you know what type of socket you need to create.
368 (i.e. inside @link(Connect) or @link(Bind) call.) When socket is created,
369 then is aplyed all stored delayed socket options.}
370 procedure CreateSocket;
371
372 {:It create socket. Address resolving of Value tells what type of socket is
373 created. If Value is resolved as IPv4 IP, then is created IPv4 socket. If
374 value is resolved as IPv6 address, then is created IPv6 socket.}
375 procedure CreateSocketByName(const Value: String);
376
377 {:Destroy socket in use. This method is also automatically called from
378 object destructor.}
379 procedure CloseSocket; virtual;
380
381 {:Abort any work on Socket and destroy them.}
382 procedure AbortSocket; virtual;
383
384 {:Connects socket to local IP address and PORT. IP address may be numeric or
385 symbolic ('192.168.74.50', 'cosi.nekde.cz', 'ff08::1'). The same for PORT
386 - it may be number or mnemonic port ('23', 'telnet').
387
388 If port value is '0', system chooses itself and conects unused port in the
389 range 1024 to 4096 (this depending by operating system!). Structure
390 LocalSin is filled after calling this method.
391
392 Note: If you call this on non-created socket, then socket is created
393 automaticly.
394
395 Warning: when you call : Bind('0.0.0.0','0'); then is nothing done! In this
396 case is used implicit system bind instead.}
397 procedure Bind(IP, Port: string);
398
399 {:Connects socket to remote IP address and PORT. The same rules as with
400 @link(BIND) method are valid. The only exception is that PORT with 0 value
401 will not be connected!
402
403 Structures LocalSin and RemoteSin will be filled with valid values.
404
405 When you call this on non-created socket, then socket is created
406 automaticly. Type of created socket is by @link(Family) property. If is
407 used SF_IP4, then is created socket for IPv4. If is used SF_IP6, then is
408 created socket for IPv6. When you have family on SF_Any (default!), then
409 type of created socket is determined by address resolving of destination
410 address. (Not work properly on prilimitary winsock IPv6 support!)}
411 procedure Connect(IP, Port: string); virtual;
412
413 {:Sets socket to receive mode for new incoming connections. It is necessary
414 to use @link(TBlockSocket.BIND) function call before this method to select
415 receiving port!}
416 procedure Listen; virtual;
417
418 {:Waits until new incoming connection comes. After it comes a new socket is
419 automatically created (socket handler is returned by this function as
420 result).}
Acceptnull421 function Accept: TSocket; virtual;
422
423 {:Sends data of LENGTH from BUFFER address via connected socket. System
424 automatically splits data to packets.}
SendBuffernull425 function SendBuffer(Buffer: Tmemory; Length: Integer): Integer; virtual;
426
427 {:One data BYTE is sent via connected socket.}
428 procedure SendByte(Data: Byte); virtual;
429
430 {:Send data string via connected socket. Any terminator is not added! If you
431 need send true string with CR-LF termination, you must add CR-LF characters
432 to sended string! Because any termination is not added automaticly, you can
433 use this function for sending any binary data in binary string.}
434 procedure SendString(Data: AnsiString); virtual;
435
436 {:Send integer as four bytes to socket.}
437 procedure SendInteger(Data: integer); virtual;
438
439 {:Send data as one block to socket. Each block begin with 4 bytes with
440 length of data in block. This 4 bytes is added automaticly by this
441 function.}
442 procedure SendBlock(const Data: AnsiString); virtual;
443
444 {:Send data from stream to socket.}
445 procedure SendStreamRaw(const Stream: TStream); virtual;
446
447 {:Send content of stream to socket. It using @link(SendBlock) method}
448 procedure SendStream(const Stream: TStream); virtual;
449
450 {:Send content of stream to socket. It using @link(SendBlock) method and
451 this is compatible with streams in Indy library.}
452 procedure SendStreamIndy(const Stream: TStream); virtual;
453
454 {:Note: This is low-level receive function. You must be sure if data is
455 waiting for read before call this function for avoid deadlock!
456
457 Waits until allocated buffer is filled by received data. Returns number of
458 data received, which equals to LENGTH value under normal operation. If it
459 is not equal the communication channel is possibly broken.
460
461 On stream oriented sockets if is received 0 bytes, it mean 'socket is
462 closed!"
463
464 On datagram socket is readed first waiting datagram.}
RecvBuffernull465 function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; virtual;
466
467 {:Note: This is high-level receive function. It using internal
468 @link(LineBuffer) and you can combine this function freely with other
469 high-level functions!
470
471 Method waits until data is received. If no data is received within TIMEOUT
472 (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. Methods
473 serves for reading any size of data (i.e. one megabyte...). This method is
474 preffered for reading from stream sockets (like TCP).}
RecvBufferExnull475 function RecvBufferEx(Buffer: Tmemory; Len: Integer;
476 Timeout: Integer): Integer; virtual;
477
478 {:Similar to @link(RecvBufferEx), but readed data is stored in binary
479 string, not in memory buffer.}
RecvBufferStrnull480 function RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString; virtual;
481
482 {:Note: This is high-level receive function. It using internal
483 @link(LineBuffer) and you can combine this function freely with other
484 high-level functions.
485
486 Waits until one data byte is received which is also returned as function
487 result. If no data is received within TIMEOUT (in milliseconds)period,
488 @link(LastError) is set to WSAETIMEDOUT and result have value 0.}
RecvBytenull489 function RecvByte(Timeout: Integer): Byte; virtual;
490
491 {:Note: This is high-level receive function. It using internal
492 @link(LineBuffer) and you can combine this function freely with other
493 high-level functions.
494
495 Waits until one four bytes are received and return it as one Ineger Value.
496 If no data is received within TIMEOUT (in milliseconds)period,
497 @link(LastError) is set to WSAETIMEDOUT and result have value 0.}
RecvIntegernull498 function RecvInteger(Timeout: Integer): Integer; virtual;
499
500 {:Note: This is high-level receive function. It using internal
501 @link(LineBuffer) and you can combine this function freely with other
502 high-level functions.
503
504 Method waits until data string is received. This string is terminated by
505 CR-LF characters. The resulting string is returned without this termination
506 (CR-LF)! If @link(ConvertLineEnd) is used, then CR-LF sequence may not be
507 exactly CR-LF. See @link(ConvertLineEnd) description. If no data is
508 received within TIMEOUT (in milliseconds) period, @link(LastError) is set
509 to WSAETIMEDOUT. You may also specify maximum length of reading data by
510 @link(MaxLineLength) property.}
RecvStringnull511 function RecvString(Timeout: Integer): AnsiString; virtual;
512
513 {:Note: This is high-level receive function. It using internal
514 @link(LineBuffer) and you can combine this function freely with other
515 high-level functions.
516
517 Method waits until data string is received. This string is terminated by
518 Terminator string. The resulting string is returned without this
519 termination. If no data is received within TIMEOUT (in milliseconds)
520 period, @link(LastError) is set to WSAETIMEDOUT. You may also specify
521 maximum length of reading data by @link(MaxLineLength) property.}
RecvTerminatednull522 function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual;
523
524 {:Note: This is high-level receive function. It using internal
525 @link(LineBuffer) and you can combine this function freely with other
526 high-level functions.
527
528 Method reads all data waiting for read. If no data is received within
529 TIMEOUT (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT.
530 Methods serves for reading unknown size of data. Because before call this
531 function you don't know size of received data, returned data is stored in
532 dynamic size binary string. This method is preffered for reading from
533 stream sockets (like TCP). It is very goot for receiving datagrams too!
534 (UDP protocol)}
RecvPacketnull535 function RecvPacket(Timeout: Integer): AnsiString; virtual;
536
537 {:Read one block of data from socket. Each block begin with 4 bytes with
538 length of data in block. This function read first 4 bytes for get lenght,
539 then it wait for reported count of bytes.}
RecvBlocknull540 function RecvBlock(Timeout: Integer): AnsiString; virtual;
541
542 {:Read all data from socket to stream until socket is closed (or any error
543 occured.)}
544 procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
545 {:Read requested count of bytes from socket to stream.}
546 procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
547
548 {:Receive data to stream. It using @link(RecvBlock) method.}
549 procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual;
550
551 {:Receive data to stream. This function is compatible with similar function
552 in Indy library. It using @link(RecvBlock) method.}
553 procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual;
554
555 {:Same as @link(RecvBuffer), but readed data stays in system input buffer.
556 Warning: this function not respect data in @link(LineBuffer)! Is not
557 recommended to use this function!}
PeekBuffernull558 function PeekBuffer(Buffer: TMemory; Length: Integer): Integer; virtual;
559
560 {:Same as @link(RecvByte), but readed data stays in input system buffer.
561 Warning: this function not respect data in @link(LineBuffer)! Is not
562 recommended to use this function!}
PeekBytenull563 function PeekByte(Timeout: Integer): Byte; virtual;
564
565 {:On stream sockets it returns number of received bytes waiting for picking.
566 0 is returned when there is no such data. On datagram socket it returns
567 length of the first waiting datagram. Returns 0 if no datagram is waiting.}
WaitingDatanull568 function WaitingData: Integer; virtual;
569
570 {:Same as @link(WaitingData), but if exists some of data in @link(Linebuffer),
571 return their length instead.}
WaitingDataExnull572 function WaitingDataEx: Integer;
573
574 {:Clear all waiting data for read from buffers.}
575 procedure Purge;
576
577 {:Sets linger. Enabled linger means that the system waits another LINGER
578 (in milliseconds) time for delivery of sent data. This function is only for
579 stream type of socket! (TCP)}
580 procedure SetLinger(Enable: Boolean; Linger: Integer);
581
582 {:Actualize values in @link(LocalSin).}
583 procedure GetSinLocal;
584
585 {:Actualize values in @link(RemoteSin).}
586 procedure GetSinRemote;
587
588 {:Actualize values in @link(LocalSin) and @link(RemoteSin).}
589 procedure GetSins;
590
591 {:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.}
592 procedure ResetLastError;
593
594 {:If you "manually" call Socket API functions, forward their return code as
595 parameter to this function, which evaluates it, eventually calls
596 GetLastError and found error code returns and stores to @link(LastError).}
SockChecknull597 function SockCheck(SockResult: Integer): Integer; virtual;
598
599 {:If @link(LastError) contains some error code and @link(RaiseExcept)
600 property is @true, raise adequate exception.}
601 procedure ExceptCheck;
602
603 {:Returns local computer name as numerical or symbolic value. It try get
604 fully qualified domain name. Name is returned in the format acceptable by
605 functions demanding IP as input parameter.}
LocalNamenull606 function LocalName: string;
607
608 {:Try resolve name to all possible IP address. i.e. If you pass as name
609 result of @link(LocalName) method, you get all IP addresses used by local
610 system.}
611 procedure ResolveNameToIP(Name: string; const IPList: TStrings);
612
613 {:Try resolve name to primary IP address. i.e. If you pass as name result of
614 @link(LocalName) method, you get primary IP addresses used by local system.}
ResolveNamenull615 function ResolveName(Name: string): string;
616
617 {:Try resolve IP to their primary domain name. If IP not have domain name,
618 then is returned original IP.}
ResolveIPToNamenull619 function ResolveIPToName(IP: string): string;
620
621 {:Try resolve symbolic port name to port number. (i.e. 'Echo' to 8)}
ResolvePortnull622 function ResolvePort(Port: string): Word;
623
624 {:Set information about remote side socket. It is good for seting remote
625 side for sending UDP packet, etc.}
626 procedure SetRemoteSin(IP, Port: string);
627
628 {:Picks IP socket address from @link(LocalSin).}
GetLocalSinIPnull629 function GetLocalSinIP: string; virtual;
630
631 {:Picks IP socket address from @link(RemoteSin).}
GetRemoteSinIPnull632 function GetRemoteSinIP: string; virtual;
633
634 {:Picks socket PORT number from @link(LocalSin).}
GetLocalSinPortnull635 function GetLocalSinPort: Integer; virtual;
636
637 {:Picks socket PORT number from @link(RemoteSin).}
GetRemoteSinPortnull638 function GetRemoteSinPort: Integer; virtual;
639
640 {:Return @TRUE, if you can read any data from socket or is incoming
641 connection on TCP based socket. Status is tested for time Timeout (in
642 milliseconds). If value in Timeout is 0, status is only tested and
643 continue. If value in Timeout is -1, run is breaked and waiting for read
644 data maybe forever.
645
646 This function is need only on special cases, when you need use
647 @link(RecvBuffer) function directly! read functioms what have timeout as
648 calling parameter, calling this function internally.}
CanReadnull649 function CanRead(Timeout: Integer): Boolean; virtual;
650
651 {:Same as @link(CanRead), but additionally return @TRUE if is some data in
652 @link(LineBuffer).}
CanReadExnull653 function CanReadEx(Timeout: Integer): Boolean; virtual;
654
655 {:Return @TRUE, if you can to socket write any data (not full sending
656 buffer). Status is tested for time Timeout (in milliseconds). If value in
657 Timeout is 0, status is only tested and continue. If value in Timeout is
658 -1, run is breaked and waiting for write data maybe forever.
659
660 This function is need only on special cases!}
CanWritenull661 function CanWrite(Timeout: Integer): Boolean; virtual;
662
663 {:Same as @link(SendBuffer), but send datagram to address from
664 @link(RemoteSin). Usefull for sending reply to datagram received by
665 function @link(RecvBufferFrom).}
SendBufferTonull666 function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; virtual;
667
668 {:Note: This is low-lever receive function. You must be sure if data is
669 waiting for read before call this function for avoid deadlock!
670
671 Receives first waiting datagram to allocated buffer. If there is no waiting
672 one, then waits until one comes. Returns length of datagram stored in
673 BUFFER. If length exceeds buffer datagram is truncated. After this
674 @link(RemoteSin) structure contains information about sender of UDP packet.}
RecvBufferFromnull675 function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; virtual;
676 {$IFNDEF CIL}
677 {:This function is for check for incoming data on set of sockets. Whitch
678 sockets is checked is decribed by SocketList Tlist with TBlockSocket
679 objects. TList may have maximal number of objects defined by FD_SETSIZE
680 constant. Return @TRUE, if you can from some socket read any data or is
681 incoming connection on TCP based socket. Status is tested for time Timeout
682 (in milliseconds). If value in Timeout is 0, status is only tested and
683 continue. If value in Timeout is -1, run is breaked and waiting for read
684 data maybe forever. If is returned @TRUE, CanReadList TList is filled by all
685 TBlockSocket objects what waiting for read.}
GroupCanReadnull686 function GroupCanRead(const SocketList: TList; Timeout: Integer;
687 const CanReadList: TList): Boolean;
688 {$ENDIF}
689 {:By this method you may turn address reuse mode for local @link(bind). It
690 is good specially for UDP protocol. Using this with TCP protocol is
691 hazardous!}
692 procedure EnableReuse(Value: Boolean);
693
694 {:Try set timeout for all sending and receiving operations, if socket
695 provider can do it. (It not supported by all socket providers!)}
696 procedure SetTimeout(Timeout: Integer);
697
698 {:Try set timeout for all sending operations, if socket provider can do it.
699 (It not supported by all socket providers!)}
700 procedure SetSendTimeout(Timeout: Integer);
701
702 {:Try set timeout for all receiving operations, if socket provider can do
703 it. (It not supported by all socket providers!)}
704 procedure SetRecvTimeout(Timeout: Integer);
705
706 {:Return value of socket type.}
GetSocketTypenull707 function GetSocketType: integer; Virtual;
708
709 {:Return value of protocol type for socket creation.}
GetSocketProtocolnull710 function GetSocketProtocol: integer; Virtual;
711
712 {:WSA structure with information about socket provider. On non-windows
713 platforms this structure is simulated!}
714 property WSAData: TWSADATA read GetWsaData;
715
716 {:FDset structure prepared for usage with this socket.}
717 property FDset: TFDSet read FFDset;
718
719 {:Structure describing local socket side.}
720 property LocalSin: TVarSin read FLocalSin write FLocalSin;
721
722 {:Structure describing remote socket side.}
723 property RemoteSin: TVarSin read FRemoteSin write FRemoteSin;
724
725 {:Socket handler. Suitable for "manual" calls to socket API or manual
726 connection of socket to a previously created socket (i.e by Accept method
727 on TCP socket)}
728 property Socket: TSocket read FSocket write SetSocket;
729
730 {:Last socket operation error code. Error codes are described in socket
731 documentation. Human readable error description is stored in
732 @link(LastErrorDesc) property.}
733 property LastError: Integer read FLastError;
734
735 {:Human readable error description of @link(LastError) code.}
736 property LastErrorDesc: string read FLastErrorDesc;
737
738 {:Buffer used by all high-level receiving functions. This buffer is used for
739 optimized reading of data from socket. In normal cases you not need access
740 to this buffer directly!}
741 property LineBuffer: AnsiString read FBuffer write FBuffer;
742
743 {:Size of Winsock receive buffer. If it is not supported by socket provider,
744 it return as size one kilobyte.}
745 property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer;
746
747 {:Size of Winsock send buffer. If it is not supported by socket provider, it
748 return as size one kilobyte.}
749 property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer;
750
751 {:If @True, turn class to non-blocking mode. Not all functions are working
752 properly in this mode, you must know exactly what you are doing! However
753 when you have big experience with non-blocking programming, then you can
754 optimise your program by non-block mode!}
755 property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode;
756
757 {:Set Time-to-live value. (if system supporting it!)}
758 property TTL: Integer read GetTTL Write SetTTL;
759
760 {:If is @true, then class in in IPv6 mode.}
761 property IP6used: Boolean read FIP6used;
762
763 {:Return count of received bytes on this socket from begin of current
764 connection.}
765 property RecvCounter: Integer read FRecvCounter;
766
767 {:Return count of sended bytes on this socket from begin of current
768 connection.}
769 property SendCounter: Integer read FSendCounter;
770 published
771 {:Return descriptive string for given error code. This is class function.
772 You may call it without created object!}
GetErrorDescnull773 class function GetErrorDesc(ErrorCode: Integer): string;
774
775 {:Return descriptive string for @link(LastError).}
GetErrorDescExnull776 function GetErrorDescEx: string; virtual;
777
778 {:this value is for free use.}
779 property Tag: Integer read FTag write FTag;
780
781 {:If @true, winsock errors raises exception. Otherwise is setted
782 @link(LastError) value only and you must check it from your program! Default
783 value is @false.}
784 property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept;
785
786 {:Define maximum length in bytes of @link(LineBuffer) for high-level
787 receiving functions. If this functions try to read more data then this
788 limit, error is returned! If value is 0 (default), no limitation is used.
789 This is very good protection for stupid attacks to your server by sending
790 lot of data without proper terminator... until all your memory is allocated
791 by LineBuffer!
792
793 Note: This maximum length is checked only in functions, what read unknown
794 number of bytes! (like @link(RecvString) or @link(RecvTerminated))}
795 property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
796
797 {:Define maximal bandwidth for all sending operations in bytes per second.
798 If value is 0 (default), bandwidth limitation is not used.}
799 property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
800
801 {:Define maximal bandwidth for all receiving operations in bytes per second.
802 If value is 0 (default), bandwidth limitation is not used.}
803 property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
804
805 {:Define maximal bandwidth for all sending and receiving operations in bytes
806 per second. If value is 0 (default), bandwidth limitation is not used.}
807 property MaxBandwidth: Integer Write SetBandwidth;
808
809 {:Do a conversion of non-standard line terminators to CRLF. (Off by default)
810 If @True, then terminators like sigle CR, single LF or LFCR are converted
811 to CRLF internally. This have effect only in @link(RecvString) method!}
812 property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
813
814 {:Specified Family of this socket. When you are using Windows preliminary
815 support for IPv6, then I recommend to set this property!}
816 property Family: TSocketFamily read FFamily Write SetFamily;
817
818 {:When resolving of domain name return both IPv4 and IPv6 addresses, then
819 specify if is used IPv4 (dafault - @true) or IPv6.}
820 property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4;
821
822 {:By default (@true) is all timeouts used as timeout between two packets in
823 reading operations. If you set this to @false, then Timeouts is for overall
824 reading operation!}
825 property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout;
826
827 {:All sended datas was splitted by this value.}
828 property SendMaxChunk: Integer read FSendMaxChunk Write FSendMaxChunk;
829
830 {:By setting this property to @true you can stop any communication. You can
831 use this property for soft abort of communication.}
832 property StopFlag: Boolean read FStopFlag Write FStopFlag;
833
834 {:Timeout for data sending by non-blocking socket mode.}
835 property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout;
836
837 {:Timeout for @link(Connect) call. Default value 0 means default system timeout.
838 Non-zero value means timeout in millisecond.}
839 property ConnectionTimeout: Integer read FConnectionTimeout write FConnectionTimeout;
840
841 {:This event is called by various reasons. It is good for monitoring socket,
842 create gauges for data transfers, etc.}
843 property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
844
845 {:this event is good for some internal thinks about filtering readed datas.
846 It is used by telnet client by example.}
847 property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter;
848
849 {:This event is called after real socket creation for setting special socket
850 options, because you not know when socket is created. (it is depended on
851 Ipv4, IPv6 or automatic mode)}
852 property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket;
853
854 {:This event is good for monitoring content of readed or writed datas.}
855 property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor;
856
857 {:This event is good for calling your code during long socket operations.
858 (Example, for refresing UI if class in not called within the thread.)
859 Rate of heartbeats can be modified by @link(HeartbeatRate) property.}
860 property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat;
861
862 {:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing.
863 Default value 0 disabling heartbeats! Value is in milliseconds.
864 Real rate can be higher or smaller then this value, because it depending
865 on real socket operations too!
866 Note: Each heartbeat slowing socket processing.}
867 property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate;
868 {:What class own this socket? Used by protocol implementation classes.}
869 property Owner: TObject read FOwner Write FOwner;
870 end;
871
872 {:@abstract(Support for SOCKS4 and SOCKS5 proxy)
873 Layer with definition all necessary properties and functions for
874 implementation SOCKS proxy client. Do not use this class directly.}
875 TSocksBlockSocket = class(TBlockSocket)
876 protected
877 FSocksIP: string;
878 FSocksPort: string;
879 FSocksTimeout: integer;
880 FSocksUsername: string;
881 FSocksPassword: string;
882 FUsingSocks: Boolean;
883 FSocksResolver: Boolean;
884 FSocksLastError: integer;
885 FSocksResponseIP: string;
886 FSocksResponsePort: string;
887 FSocksLocalIP: string;
888 FSocksLocalPort: string;
889 FSocksRemoteIP: string;
890 FSocksRemotePort: string;
891 FBypassFlag: Boolean;
892 FSocksType: TSocksType;
SocksCodenull893 function SocksCode(IP, Port: string): Ansistring;
SocksDecodenull894 function SocksDecode(Value: Ansistring): integer;
895 public
896 constructor Create;
897
898 {:Open connection to SOCKS proxy and if @link(SocksUsername) is set, do
899 authorisation to proxy. This is needed only in special cases! (it is called
900 internally!)}
SocksOpennull901 function SocksOpen: Boolean;
902
903 {:Send specified request to SOCKS proxy. This is needed only in special
904 cases! (it is called internally!)}
SocksRequestnull905 function SocksRequest(Cmd: Byte; const IP, Port: string): Boolean;
906
907 {:Receive response to previosly sended request. This is needed only in
908 special cases! (it is called internally!)}
SocksResponsenull909 function SocksResponse: Boolean;
910
911 {:Is @True when class is using SOCKS proxy.}
912 property UsingSocks: Boolean read FUsingSocks;
913
914 {:If SOCKS proxy failed, here is error code returned from SOCKS proxy.}
915 property SocksLastError: integer read FSocksLastError;
916 published
917 {:Address of SOCKS server. If value is empty string, SOCKS support is
918 disabled. Assingning any value to this property enable SOCKS mode.
919 Warning: You cannot combine this mode with HTTP-tunneling mode!}
920 property SocksIP: string read FSocksIP write FSocksIP;
921
922 {:Port of SOCKS server. Default value is '1080'.}
923 property SocksPort: string read FSocksPort write FSocksPort;
924
925 {:If you need authorisation on SOCKS server, set username here.}
926 property SocksUsername: string read FSocksUsername write FSocksUsername;
927
928 {:If you need authorisation on SOCKS server, set password here.}
929 property SocksPassword: string read FSocksPassword write FSocksPassword;
930
931 {:Specify timeout for communicatin with SOCKS server. Default is one minute.}
932 property SocksTimeout: integer read FSocksTimeout write FSocksTimeout;
933
934 {:If @True, all symbolic names of target hosts is not translated to IP's
935 locally, but resolving is by SOCKS proxy. Default is @True.}
936 property SocksResolver: Boolean read FSocksResolver write FSocksResolver;
937
938 {:Specify SOCKS type. By default is used SOCKS5, but you can use SOCKS4 too.
939 When you select SOCKS4, then if @link(SOCKSResolver) is enabled, then is
940 used SOCKS4a. Othervise is used pure SOCKS4.}
941 property SocksType: TSocksType read FSocksType write FSocksType;
942 end;
943
944 {:@abstract(Implementation of TCP socket.)
945 Supported features: IPv4, IPv6, SSL/TLS or SSH (depending on used plugin),
946 SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy
947 (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.}
948 TTCPBlockSocket = class(TSocksBlockSocket)
949 protected
950 FOnAfterConnect: THookAfterConnect;
951 FSSL: TCustomSSL;
952 FHTTPTunnelIP: string;
953 FHTTPTunnelPort: string;
954 FHTTPTunnel: Boolean;
955 FHTTPTunnelRemoteIP: string;
956 FHTTPTunnelRemotePort: string;
957 FHTTPTunnelUser: string;
958 FHTTPTunnelPass: string;
959 FHTTPTunnelTimeout: integer;
960 procedure SocksDoConnect(IP, Port: string);
961 procedure HTTPTunnelDoConnect(IP, Port: string);
962 procedure DoAfterConnect;
963 public
964 {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation
965 (see @link(SSLImplementation))}
966 constructor Create;
967
968 {:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation}
969 constructor CreateWithSSL(SSLPlugin: TSSLClass);
970 destructor Destroy; override;
971
972 {:See @link(TBlockSocket.CloseSocket)}
973 procedure CloseSocket; override;
974
975 {:See @link(TBlockSocket.WaitingData)}
WaitingDatanull976 function WaitingData: Integer; override;
977
978 {:Sets socket to receive mode for new incoming connections. It is necessary
979 to use @link(TBlockSocket.BIND) function call before this method to select
980 receiving port!
981
982 If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND
983 method of SOCKS.)}
984 procedure Listen; override;
985
986 {:Waits until new incoming connection comes. After it comes a new socket is
987 automatically created (socket handler is returned by this function as
988 result).
989
990 If you use SOCKS, new socket is not created! In this case is used same
991 socket as socket for listening! So, you can accept only one connection in
992 SOCKS mode.}
Acceptnull993 function Accept: TSocket; override;
994
995 {:Connects socket to remote IP address and PORT. The same rules as with
996 @link(TBlockSocket.BIND) method are valid. The only exception is that PORT
997 with 0 value will not be connected. After call to this method
998 a communication channel between local and remote socket is created. Local
999 socket is assigned automatically if not controlled by previous call to
1000 @link(TBlockSocket.BIND) method. Structures @link(TBlockSocket.LocalSin)
1001 and @link(TBlockSocket.RemoteSin) will be filled with valid values.
1002
1003 If you use SOCKS, activate outgoing TCP connection by SOCKS proxy specified
1004 in @link(TSocksBlockSocket.SocksIP). (By CONNECT method of SOCKS.)
1005
1006 If you use HTTP-tunnel mode, activate outgoing TCP connection by HTTP
1007 tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP
1008 protocol.)
1009
1010 Note: If you call this on non-created socket, then socket is created
1011 automaticly.}
1012 procedure Connect(IP, Port: string); override;
1013
1014 {:If you need upgrade existing TCP connection to SSL/TLS (or SSH2, if plugin
1015 allows it) mode, then call this method. This method switch this class to
1016 SSL mode and do SSL/TSL handshake.}
1017 procedure SSLDoConnect;
1018
1019 {:By this method you can downgrade existing SSL/TLS connection to normal TCP
1020 connection.}
1021 procedure SSLDoShutdown;
1022
1023 {:If you need use this component as SSL/TLS TCP server, then after accepting
1024 of inbound connection you need start SSL/TLS session by this method. Before
1025 call this function, you must have assigned all neeeded certificates and
1026 keys!}
SSLAcceptConnectionnull1027 function SSLAcceptConnection: Boolean;
1028
1029 {:See @link(TBlockSocket.GetLocalSinIP)}
GetLocalSinIPnull1030 function GetLocalSinIP: string; override;
1031
1032 {:See @link(TBlockSocket.GetRemoteSinIP)}
GetRemoteSinIPnull1033 function GetRemoteSinIP: string; override;
1034
1035 {:See @link(TBlockSocket.GetLocalSinPort)}
GetLocalSinPortnull1036 function GetLocalSinPort: Integer; override;
1037
1038 {:See @link(TBlockSocket.GetRemoteSinPort)}
GetRemoteSinPortnull1039 function GetRemoteSinPort: Integer; override;
1040
1041 {:See @link(TBlockSocket.SendBuffer)}
SendBuffernull1042 function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override;
1043
1044 {:See @link(TBlockSocket.RecvBuffer)}
RecvBuffernull1045 function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
1046
1047 {:Return value of socket type. For TCP return SOCK_STREAM.}
GetSocketTypenull1048 function GetSocketType: integer; override;
1049
1050 {:Return value of protocol type for socket creation. For TCP return
1051 IPPROTO_TCP.}
GetSocketProtocolnull1052 function GetSocketProtocol: integer; override;
1053
1054 {:Class implementing SSL/TLS support. It is allways some descendant
1055 of @link(TCustomSSL) class. When programmer not select some SSL plugin
1056 class, then is used @link(TSSLNone)}
1057 property SSL: TCustomSSL read FSSL;
1058
1059 {:@True if is used HTTP tunnel mode.}
1060 property HTTPTunnel: Boolean read FHTTPTunnel;
1061 published
1062 {:Return descriptive string for @link(LastError). On case of error
1063 in SSL/TLS subsystem, it returns right error description.}
GetErrorDescExnull1064 function GetErrorDescEx: string; override;
1065
1066 {:Specify IP address of HTTP proxy. Assingning non-empty value to this
1067 property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing
1068 TCP connection through HTTP proxy server. (If policy on HTTP proxy server
1069 allow this!) Warning: You cannot combine this mode with SOCK5 mode!}
1070 property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP;
1071
1072 {:Specify port of HTTP proxy for HTTP-tunneling.}
1073 property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort;
1074
1075 {:Specify authorisation username for access to HTTP proxy in HTTP-tunnel
1076 mode. If you not need authorisation, then let this property empty.}
1077 property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser;
1078
1079 {:Specify authorisation password for access to HTTP proxy in HTTP-tunnel
1080 mode.}
1081 property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass;
1082
1083 {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.}
1084 property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout;
1085
1086 {:This event is called after sucessful TCP socket connection.}
1087 property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect;
1088 end;
1089
1090 {:@abstract(Datagram based communication)
1091 This class implementing datagram based communication instead default stream
1092 based communication style.}
1093 TDgramBlockSocket = class(TSocksBlockSocket)
1094 public
1095 {:Fill @link(TBlockSocket.RemoteSin) structure. This address is used for
1096 sending data.}
1097 procedure Connect(IP, Port: string); override;
1098
1099 {:Silently redirected to @link(TBlockSocket.SendBufferTo).}
SendBuffernull1100 function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override;
1101
1102 {:Silently redirected to @link(TBlockSocket.RecvBufferFrom).}
RecvBuffernull1103 function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override;
1104 end;
1105
1106 {:@abstract(Implementation of UDP socket.)
1107 NOTE: in this class is all receiving redirected to RecvBufferFrom. You can
1108 use for reading any receive function. Preffered is RecvPacket! Similary all
1109 sending is redirected to SendbufferTo. You can use for sending UDP packet any
1110 sending function, like SendString.
1111
1112 Supported features: IPv4, IPv6, unicasts, broadcasts, multicasts, SOCKS5
1113 proxy (only unicasts! Outgoing and incomming.)}
1114 TUDPBlockSocket = class(TDgramBlockSocket)
1115 protected
1116 FSocksControlSock: TTCPBlockSocket;
UdpAssociationnull1117 function UdpAssociation: Boolean;
1118 procedure SetMulticastTTL(TTL: integer);
GetMulticastTTLnull1119 function GetMulticastTTL:integer;
1120 public
1121 destructor Destroy; override;
1122
1123 {:Enable or disable sending of broadcasts. If seting OK, result is @true.
1124 This method is not supported in SOCKS5 mode! IPv6 does not support
1125 broadcasts! In this case you must use Multicasts instead.}
1126 procedure EnableBroadcast(Value: Boolean);
1127
1128 {:See @link(TBlockSocket.SendBufferTo)}
SendBufferTonull1129 function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; override;
1130
1131 {:See @link(TBlockSocket.RecvBufferFrom)}
RecvBufferFromnull1132 function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override;
1133 {$IFNDEF CIL}
1134 {:Add this socket to given multicast group. You cannot use Multicasts in
1135 SOCKS mode!}
1136 procedure AddMulticast(MCastIP:string);
1137
1138 {:Remove this socket from given multicast group.}
1139 procedure DropMulticast(MCastIP:string);
1140 {$ENDIF}
1141 {:All sended multicast datagrams is loopbacked to your interface too. (you
1142 can read your sended datas.) You can disable this feature by this function.
1143 This function not working on some Windows systems!}
1144 procedure EnableMulticastLoop(Value: Boolean);
1145
1146 {:Return value of socket type. For UDP return SOCK_DGRAM.}
GetSocketTypenull1147 function GetSocketType: integer; override;
1148
1149 {:Return value of protocol type for socket creation. For UDP return
1150 IPPROTO_UDP.}
GetSocketProtocolnull1151 function GetSocketProtocol: integer; override;
1152
1153 {:Set Time-to-live value for multicasts packets. It define number of routers
1154 for transfer of datas. If you set this to 1 (dafault system value), then
1155 multicasts packet goes only to you local network. If you need transport
1156 multicast packet to worldwide, then increase this value, but be carefull,
1157 lot of routers on internet does not transport multicasts packets!}
1158 property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL;
1159 end;
1160
1161 {:@abstract(Implementation of RAW ICMP socket.)
1162 For this object you must have rights for creating RAW sockets!}
1163 TICMPBlockSocket = class(TDgramBlockSocket)
1164 public
1165 {:Return value of socket type. For RAW and ICMP return SOCK_RAW.}
GetSocketTypenull1166 function GetSocketType: integer; override;
1167
1168 {:Return value of protocol type for socket creation. For ICMP returns
1169 IPPROTO_ICMP or IPPROTO_ICMPV6}
GetSocketProtocolnull1170 function GetSocketProtocol: integer; override;
1171 end;
1172
1173 {:@abstract(Implementation of RAW socket.)
1174 For this object you must have rights for creating RAW sockets!}
1175 TRAWBlockSocket = class(TBlockSocket)
1176 public
1177 {:Return value of socket type. For RAW and ICMP return SOCK_RAW.}
GetSocketTypenull1178 function GetSocketType: integer; override;
1179
1180 {:Return value of protocol type for socket creation. For RAW returns
1181 IPPROTO_RAW.}
GetSocketProtocolnull1182 function GetSocketProtocol: integer; override;
1183 end;
1184
1185 {:@abstract(Implementation of PGM-message socket.)
1186 Not all systems supports this protocol!}
1187 TPGMMessageBlockSocket = class(TBlockSocket)
1188 public
1189 {:Return value of socket type. For PGM-message return SOCK_RDM.}
GetSocketTypenull1190 function GetSocketType: integer; override;
1191
1192 {:Return value of protocol type for socket creation. For PGM-message returns
1193 IPPROTO_RM.}
GetSocketProtocolnull1194 function GetSocketProtocol: integer; override;
1195 end;
1196
1197 {:@abstract(Implementation of PGM-stream socket.)
1198 Not all systems supports this protocol!}
1199 TPGMStreamBlockSocket = class(TBlockSocket)
1200 public
1201 {:Return value of socket type. For PGM-stream return SOCK_STREAM.}
GetSocketTypenull1202 function GetSocketType: integer; override;
1203
1204 {:Return value of protocol type for socket creation. For PGM-stream returns
1205 IPPROTO_RM.}
GetSocketProtocolnull1206 function GetSocketProtocol: integer; override;
1207 end;
1208
1209 {:@abstract(Parent class for all SSL plugins.)
1210 This is abstract class defining interface for other SSL plugins.
1211
1212 Instance of this class will be created for each @link(TTCPBlockSocket).
1213
1214 Warning: not all methods and propertis can work in all existing SSL plugins!
1215 Please, read documentation of used SSL plugin.}
1216 TCustomSSL = class(TObject)
1217 private
1218 protected
1219 FOnVerifyCert: THookVerifyCert;
1220 FSocket: TTCPBlockSocket;
1221 FSSLEnabled: Boolean;
1222 FLastError: integer;
1223 FLastErrorDesc: string;
1224 FSSLType: TSSLType;
1225 FKeyPassword: string;
1226 FCiphers: string;
1227 FCertificateFile: string;
1228 FPrivateKeyFile: string;
1229 FCertificate: Ansistring;
1230 FPrivateKey: Ansistring;
1231 FPFX: Ansistring;
1232 FPFXfile: string;
1233 FCertCA: Ansistring;
1234 FCertCAFile: string;
1235 FTrustCertificate: Ansistring;
1236 FTrustCertificateFile: string;
1237 FVerifyCert: Boolean;
1238 FUsername: string;
1239 FPassword: string;
1240 FSSHChannelType: string;
1241 FSSHChannelArg1: string;
1242 FSSHChannelArg2: string;
1243 FCertComplianceLevel: integer;
1244 FSNIHost: string;
1245 procedure ReturnError;
1246 procedure SetCertCAFile(const Value: string); virtual;
DoVerifyCertnull1247 function DoVerifyCert:boolean;
CreateSelfSignedCertnull1248 function CreateSelfSignedCert(Host: string): Boolean; virtual;
1249 public
1250 {: Create plugin class. it is called internally from @link(TTCPBlockSocket)}
1251 constructor Create(const Value: TTCPBlockSocket); virtual;
1252
1253 {: Assign settings (certificates and configuration) from another SSL plugin
1254 class.}
1255 procedure Assign(const Value: TCustomSSL); virtual;
1256
1257 {: return description of used plugin. It usually return name and version
1258 of used SSL library.}
LibVersionnull1259 function LibVersion: String; virtual;
1260
1261 {: return name of used plugin.}
LibNamenull1262 function LibName: String; virtual;
1263
1264 {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1265
1266 Here is needed code for start SSL connection.}
Connectnull1267 function Connect: boolean; virtual;
1268
1269 {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1270
1271 Here is needed code for acept new SSL connection.}
Acceptnull1272 function Accept: boolean; virtual;
1273
1274 {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1275
1276 Here is needed code for hard shutdown of SSL connection. (for example,
1277 before socket is closed)}
Shutdownnull1278 function Shutdown: boolean; virtual;
1279
1280 {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1281
1282 Here is needed code for soft shutdown of SSL connection. (for example,
1283 when you need to continue with unprotected connection.)}
BiShutdownnull1284 function BiShutdown: boolean; virtual;
1285
1286 {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1287
1288 Here is needed code for sending some datas by SSL connection.}
SendBuffernull1289 function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual;
1290
1291 {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1292
1293 Here is needed code for receiving some datas by SSL connection.}
RecvBuffernull1294 function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual;
1295
1296 {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1297
1298 Here is needed code for getting count of datas what waiting for read.
1299 If SSL plugin not allows this, then it should return 0.}
WaitingDatanull1300 function WaitingData: Integer; virtual;
1301
1302 {:Return string with identificator of SSL/TLS version of existing
1303 connection.}
GetSSLVersionnull1304 function GetSSLVersion: string; virtual;
1305
1306 {:Return subject of remote SSL peer.}
GetPeerSubjectnull1307 function GetPeerSubject: string; virtual;
1308
1309 {:Return Serial number if remote X509 certificate.}
GetPeerSerialNonull1310 function GetPeerSerialNo: integer; virtual;
1311
1312 {:Return issuer certificate of remote SSL peer.}
GetPeerIssuernull1313 function GetPeerIssuer: string; virtual;
1314
1315 {:Return peer name from remote side certificate. This is good for verify,
1316 if certificate is generated for remote side IP name.}
GetPeerNamenull1317 function GetPeerName: string; virtual;
1318
1319 {:Returns has of peer name from remote side certificate. This is good
1320 for fast remote side authentication.}
GetPeerNameHashnull1321 function GetPeerNameHash: cardinal; virtual;
1322
1323 {:Return fingerprint of remote SSL peer.}
GetPeerFingerprintnull1324 function GetPeerFingerprint: string; virtual;
1325
1326 {:Return all detailed information about certificate from remote side of
1327 SSL/TLS connection. Result string can be multilined! Each plugin can return
1328 this informations in different format!}
GetCertInfonull1329 function GetCertInfo: string; virtual;
1330
1331 {:Return currently used Cipher.}
GetCipherNamenull1332 function GetCipherName: string; virtual;
1333
1334 {:Return currently used number of bits in current Cipher algorythm.}
GetCipherBitsnull1335 function GetCipherBits: integer; virtual;
1336
1337 {:Return number of bits in current Cipher algorythm.}
GetCipherAlgBitsnull1338 function GetCipherAlgBits: integer; virtual;
1339
1340 {:Return result value of verify remote side certificate. Look to OpenSSL
1341 documentation for possible values. For example 0 is successfuly verified
1342 certificate, or 18 is self-signed certificate.}
GetVerifyCertnull1343 function GetVerifyCert: integer; virtual;
1344
1345 {: Resurn @true if SSL mode is enabled on existing cvonnection.}
1346 property SSLEnabled: Boolean read FSSLEnabled;
1347
1348 {:Return error code of last SSL operation. 0 is OK.}
1349 property LastError: integer read FLastError;
1350
1351 {:Return error description of last SSL operation.}
1352 property LastErrorDesc: string read FLastErrorDesc;
1353 published
1354 {:Here you can specify requested SSL/TLS mode. Default is autodetection, but
1355 on some servers autodetection not working properly. In this case you must
1356 specify requested SSL/TLS mode by your hand!}
1357 property SSLType: TSSLType read FSSLType write FSSLType;
1358
1359 {:Password for decrypting of encoded certificate or key.}
1360 property KeyPassword: string read FKeyPassword write FKeyPassword;
1361
1362 {:Username for possible credentials.}
1363 property Username: string read FUsername write FUsername;
1364
1365 {:password for possible credentials.}
1366 property Password: string read FPassword write FPassword;
1367
1368 {:By this property you can modify default set of SSL/TLS ciphers.}
1369 property Ciphers: string read FCiphers write FCiphers;
1370
1371 {:Used for loading certificate from disk file. See to plugin documentation
1372 if this method is supported and how!}
1373 property CertificateFile: string read FCertificateFile write FCertificateFile;
1374
1375 {:Used for loading private key from disk file. See to plugin documentation
1376 if this method is supported and how!}
1377 property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile;
1378
1379 {:Used for loading certificate from binary string. See to plugin documentation
1380 if this method is supported and how!}
1381 property Certificate: Ansistring read FCertificate write FCertificate;
1382
1383 {:Used for loading private key from binary string. See to plugin documentation
1384 if this method is supported and how!}
1385 property PrivateKey: Ansistring read FPrivateKey write FPrivateKey;
1386
1387 {:Used for loading PFX from binary string. See to plugin documentation
1388 if this method is supported and how!}
1389 property PFX: Ansistring read FPFX write FPFX;
1390
1391 {:Used for loading PFX from disk file. See to plugin documentation
1392 if this method is supported and how!}
1393 property PFXfile: string read FPFXfile write FPFXfile;
1394
1395 {:Used for loading trusted certificates from disk file. See to plugin documentation
1396 if this method is supported and how!}
1397 property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile;
1398
1399 {:Used for loading trusted certificates from binary string. See to plugin documentation
1400 if this method is supported and how!}
1401 property TrustCertificate: Ansistring read FTrustCertificate write FTrustCertificate;
1402
1403 {:Used for loading CA certificates from binary string. See to plugin documentation
1404 if this method is supported and how!}
1405 property CertCA: Ansistring read FCertCA write FCertCA;
1406
1407 {:Used for loading CA certificates from disk file. See to plugin documentation
1408 if this method is supported and how!}
1409 property CertCAFile: string read FCertCAFile write SetCertCAFile;
1410
1411 {:If @true, then is verified client certificate. (it is good for writing
1412 SSL/TLS servers.) When you are not server, but you are client, then if this
1413 property is @true, verify servers certificate.}
1414 property VerifyCert: Boolean read FVerifyCert write FVerifyCert;
1415
1416 {:channel type for possible SSH connections}
1417 property SSHChannelType: string read FSSHChannelType write FSSHChannelType;
1418
1419 {:First argument of channel type for possible SSH connections}
1420 property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1;
1421
1422 {:Second argument of channel type for possible SSH connections}
1423 property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2;
1424
1425 {: Level of standards compliance level
1426 (CryptLib: values in cryptlib.pas, -1: use default value ) }
1427 property CertComplianceLevel:integer read FCertComplianceLevel write FCertComplianceLevel;
1428
1429 {:This event is called when verifying the server certificate immediatally after
1430 a successfull verification in the ssl library.}
1431 property OnVerifyCert: THookVerifyCert read FOnVerifyCert write FOnVerifyCert;
1432
1433 {: Server Name Identification. Host name to send to server. If empty the host name
1434 found in URL will be used, which should be the normal use (http Header Host = SNI Host).
1435 The value is cleared after the connection is established.
1436 (SNI support requires OpenSSL 0.9.8k or later. Cryptlib not supported, yet ) }
1437 property SNIHost:string read FSNIHost write FSNIHost;
1438 end;
1439
1440 {:@abstract(Default SSL plugin with no SSL support.)
1441 Dummy SSL plugin implementation for applications without SSL/TLS support.}
1442 TSSLNone = class (TCustomSSL)
1443 public
1444 {:See @inherited}
LibVersionnull1445 function LibVersion: String; override;
1446 {:See @inherited}
LibNamenull1447 function LibName: String; override;
1448 end;
1449
1450 {:@abstract(Record with definition of IP packet header.)
1451 For reading data from ICMP or RAW sockets.}
1452 TIPHeader = record
1453 VerLen: Byte;
1454 TOS: Byte;
1455 TotalLen: Word;
1456 Identifer: Word;
1457 FragOffsets: Word;
1458 TTL: Byte;
1459 Protocol: Byte;
1460 CheckSum: Word;
1461 SourceIp: LongWord;
1462 DestIp: LongWord;
1463 Options: LongWord;
1464 end;
1465
1466 {:@abstract(Parent class of application protocol implementations.)
1467 By this class is defined common properties.}
1468 TSynaClient = Class(TObject)
1469 protected
1470 FTargetHost: string;
1471 FTargetPort: string;
1472 FIPInterface: string;
1473 FTimeout: integer;
1474 FUserName: string;
1475 FPassword: string;
1476 public
1477 constructor Create;
1478 published
1479 {:Specify terget server IP (or symbolic name). Default is 'localhost'.}
1480 property TargetHost: string read FTargetHost Write FTargetHost;
1481
1482 {:Specify terget server port (or symbolic name).}
1483 property TargetPort: string read FTargetPort Write FTargetPort;
1484
1485 {:Defined local socket address. (outgoing IP address). By default is used
1486 '0.0.0.0' as wildcard for default IP.}
1487 property IPInterface: string read FIPInterface Write FIPInterface;
1488
1489 {:Specify default timeout for socket operations.}
1490 property Timeout: integer read FTimeout Write FTimeout;
1491
1492 {:If protocol need user authorization, then fill here username.}
1493 property UserName: string read FUserName Write FUserName;
1494
1495 {:If protocol need user authorization, then fill here password.}
1496 property Password: string read FPassword Write FPassword;
1497 end;
1498
1499 var
1500 {:Selected SSL plugin. Default is @link(TSSLNone).
1501
1502 Do not change this value directly!!!
1503
1504 Just add your plugin unit to your project uses instead. Each plugin unit have
1505 initialization code what modify this variable.}
1506 SSLImplementation: TSSLClass = TSSLNone;
1507
1508 implementation
1509
1510 {$IFDEF ONCEWINSOCK}
1511 var
1512 WsaDataOnce: TWSADATA;
1513 e: ESynapseError;
1514 {$ENDIF}
1515
1516
1517 constructor TBlockSocket.Create;
1518 begin
1519 CreateAlternate('');
1520 end;
1521
1522 constructor TBlockSocket.CreateAlternate(Stub: string);
1523 {$IFNDEF ONCEWINSOCK}
1524 var
1525 e: ESynapseError;
1526 {$ENDIF}
1527 begin
1528 inherited Create;
1529 FDelayedOptions := TList.Create;
1530 FRaiseExcept := False;
1531 {$IFDEF RAISEEXCEPT}
1532 FRaiseExcept := True;
1533 {$ENDIF}
1534 FSocket := INVALID_SOCKET;
1535 FBuffer := '';
1536 FLastCR := False;
1537 FLastLF := False;
1538 FBinded := False;
1539 FNonBlockMode := False;
1540 FMaxLineLength := 0;
1541 FMaxSendBandwidth := 0;
1542 FNextSend := 0;
1543 FMaxRecvBandwidth := 0;
1544 FNextRecv := 0;
1545 FConvertLineEnd := False;
1546 FFamily := SF_Any;
1547 FFamilySave := SF_Any;
1548 FIP6used := False;
1549 FPreferIP4 := True;
1550 FInterPacketTimeout := True;
1551 FRecvCounter := 0;
1552 FSendCounter := 0;
1553 FSendMaxChunk := c64k;
1554 FStopFlag := False;
1555 FNonblockSendTimeout := 15000;
1556 FHeartbeatRate := 0;
1557 FConnectionTimeout := 0;
1558 FOwner := nil;
1559 {$IFNDEF ONCEWINSOCK}
1560 if Stub = '' then
1561 Stub := DLLStackName;
1562 if not InitSocketInterface(Stub) then
1563 begin
1564 e := ESynapseError.Create('Error loading Socket interface (' + Stub + ')!');
1565 e.ErrorCode := 0;
1566 e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!';
1567 raise e;
1568 end;
1569 SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce));
1570 ExceptCheck;
1571 {$ENDIF}
1572 end;
1573
1574 destructor TBlockSocket.Destroy;
1575 var
1576 n: integer;
1577 p: TSynaOption;
1578 begin
1579 CloseSocket;
1580 {$IFNDEF ONCEWINSOCK}
1581 synsock.WSACleanup;
1582 DestroySocketInterface;
1583 {$ENDIF}
1584 for n := FDelayedOptions.Count - 1 downto 0 do
1585 begin
1586 p := TSynaOption(FDelayedOptions[n]);
1587 p.Free;
1588 end;
1589 FDelayedOptions.Free;
1590 inherited Destroy;
1591 end;
1592
TBlockSocket.FamilyToAFnull1593 function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily;
1594 begin
1595 case f of
1596 SF_ip4:
1597 Result := AF_INET;
1598 SF_ip6:
1599 Result := AF_INET6;
1600 else
1601 Result := AF_UNSPEC;
1602 end;
1603 end;
1604
1605 procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption);
1606 var
1607 li: TLinger;
1608 x: integer;
1609 buf: TMemory;
1610 {$IFNDEF MSWINDOWS}
1611 timeval: TTimeval;
1612 {$ENDIF}
1613 begin
1614 case value.Option of
1615 SOT_Linger:
1616 begin
1617 {$IFDEF CIL}
1618 li := TLinger.Create(Value.Enabled, Value.Value div 1000);
1619 synsock.SetSockOptObj(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), li);
1620 {$ELSE}
1621 li.l_onoff := Ord(Value.Enabled);
1622 li.l_linger := Value.Value div 1000;
1623 buf := @li;
1624 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li));
1625 {$ENDIF}
1626 end;
1627 SOT_RecvBuff:
1628 begin
1629 {$IFDEF CIL}
1630 buf := System.BitConverter.GetBytes(value.Value);
1631 {$ELSE}
1632 buf := @Value.Value;
1633 {$ENDIF}
1634 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF),
1635 buf, SizeOf(Value.Value));
1636 end;
1637 SOT_SendBuff:
1638 begin
1639 {$IFDEF CIL}
1640 buf := System.BitConverter.GetBytes(value.Value);
1641 {$ELSE}
1642 buf := @Value.Value;
1643 {$ENDIF}
1644 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF),
1645 buf, SizeOf(Value.Value));
1646 end;
1647 SOT_NonBlock:
1648 begin
1649 FNonBlockMode := Value.Enabled;
1650 x := Ord(FNonBlockMode);
1651 synsock.IoctlSocket(FSocket, FIONBIO, x);
1652 end;
1653 SOT_RecvTimeout:
1654 begin
1655 {$IFDEF CIL}
1656 buf := System.BitConverter.GetBytes(value.Value);
1657 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
1658 buf, SizeOf(Value.Value));
1659 {$ELSE}
1660 {$IFDEF MSWINDOWS}
1661 buf := @Value.Value;
1662 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
1663 buf, SizeOf(Value.Value));
1664 {$ELSE}
1665 timeval.tv_sec:=Value.Value div 1000;
1666 timeval.tv_usec:=(Value.Value mod 1000) * 1000;
1667 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
1668 @timeval, SizeOf(timeval));
1669 {$ENDIF}
1670 {$ENDIF}
1671 end;
1672 SOT_SendTimeout:
1673 begin
1674 {$IFDEF CIL}
1675 buf := System.BitConverter.GetBytes(value.Value);
1676 {$ELSE}
1677 {$IFDEF MSWINDOWS}
1678 buf := @Value.Value;
1679 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
1680 buf, SizeOf(Value.Value));
1681 {$ELSE}
1682 timeval.tv_sec:=Value.Value div 1000;
1683 timeval.tv_usec:=(Value.Value mod 1000) * 1000;
1684 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
1685 @timeval, SizeOf(timeval));
1686 {$ENDIF}
1687 {$ENDIF}
1688 end;
1689 SOT_Reuse:
1690 begin
1691 x := Ord(Value.Enabled);
1692 {$IFDEF CIL}
1693 buf := System.BitConverter.GetBytes(x);
1694 {$ELSE}
1695 buf := @x;
1696 {$ENDIF}
1697 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_REUSEADDR), buf, SizeOf(x));
1698 end;
1699 SOT_TTL:
1700 begin
1701 {$IFDEF CIL}
1702 buf := System.BitConverter.GetBytes(value.Value);
1703 {$ELSE}
1704 buf := @Value.Value;
1705 {$ENDIF}
1706 if FIP6Used then
1707 synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS),
1708 buf, SizeOf(Value.Value))
1709 else
1710 synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_TTL),
1711 buf, SizeOf(Value.Value));
1712 end;
1713 SOT_Broadcast:
1714 begin
1715 //#todo1 broadcasty na IP6
1716 x := Ord(Value.Enabled);
1717 {$IFDEF CIL}
1718 buf := System.BitConverter.GetBytes(x);
1719 {$ELSE}
1720 buf := @x;
1721 {$ENDIF}
1722 synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_BROADCAST), buf, SizeOf(x));
1723 end;
1724 SOT_MulticastTTL:
1725 begin
1726 {$IFDEF CIL}
1727 buf := System.BitConverter.GetBytes(value.Value);
1728 {$ELSE}
1729 buf := @Value.Value;
1730 {$ENDIF}
1731 if FIP6Used then
1732 synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS),
1733 buf, SizeOf(Value.Value))
1734 else
1735 synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL),
1736 buf, SizeOf(Value.Value));
1737 end;
1738 SOT_MulticastLoop:
1739 begin
1740 x := Ord(Value.Enabled);
1741 {$IFDEF CIL}
1742 buf := System.BitConverter.GetBytes(x);
1743 {$ELSE}
1744 buf := @x;
1745 {$ENDIF}
1746 if FIP6Used then
1747 synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x))
1748 else
1749 synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x));
1750 end;
1751 end;
1752 Value.free;
1753 end;
1754
1755 procedure TBlockSocket.DelayedOption(const Value: TSynaOption);
1756 begin
1757 if FSocket = INVALID_SOCKET then
1758 begin
1759 FDelayedOptions.Insert(0, Value);
1760 end
1761 else
1762 SetDelayedOption(Value);
1763 end;
1764
1765 procedure TBlockSocket.ProcessDelayedOptions;
1766 var
1767 n: integer;
1768 d: TSynaOption;
1769 begin
1770 for n := FDelayedOptions.Count - 1 downto 0 do
1771 begin
1772 d := TSynaOption(FDelayedOptions[n]);
1773 SetDelayedOption(d);
1774 end;
1775 FDelayedOptions.Clear;
1776 end;
1777
1778 procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string);
1779 var
1780 f: TSocketFamily;
1781 begin
1782 DoStatus(HR_ResolvingBegin, IP + ':' + Port);
1783 ResetLastError;
1784 //if socket exists, then use their type, else use users selection
1785 f := SF_Any;
1786 if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then
1787 begin
1788 if IsIP(IP) then
1789 f := SF_IP4
1790 else
1791 if IsIP6(IP) then
1792 f := SF_IP6;
1793 end
1794 else
1795 f := FFamily;
1796 FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f),
1797 GetSocketprotocol, GetSocketType, FPreferIP4);
1798 DoStatus(HR_ResolvingEnd, GetSinIP(sin) + ':' + IntTostr(GetSinPort(sin)));
1799 end;
1800
TBlockSocket.GetSinIPnull1801 function TBlockSocket.GetSinIP(Sin: TVarSin): string;
1802 begin
1803 Result := synsock.GetSinIP(sin);
1804 end;
1805
TBlockSocket.GetSinPortnull1806 function TBlockSocket.GetSinPort(Sin: TVarSin): Integer;
1807 begin
1808 Result := synsock.GetSinPort(sin);
1809 end;
1810
1811 procedure TBlockSocket.CreateSocket;
1812 var
1813 sin: TVarSin;
1814 begin
1815 //dummy for SF_Any Family mode
1816 ResetLastError;
1817 if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then
1818 begin
1819 {$IFDEF CIL}
1820 if FFamily = SF_IP6 then
1821 sin := TVarSin.Create(IPAddress.Parse('::0'), 0)
1822 else
1823 sin := TVarSin.Create(IPAddress.Parse('0.0.0.0'), 0);
1824 {$ELSE}
1825 FillChar(Sin, Sizeof(Sin), 0);
1826 if FFamily = SF_IP6 then
1827 sin.sin_family := AF_INET6
1828 else
1829 sin.sin_family := AF_INET;
1830 {$ENDIF}
1831 InternalCreateSocket(Sin);
1832 end;
1833 end;
1834
1835 procedure TBlockSocket.CreateSocketByName(const Value: String);
1836 var
1837 sin: TVarSin;
1838 begin
1839 ResetLastError;
1840 if FSocket = INVALID_SOCKET then
1841 begin
1842 SetSin(sin, value, '0');
1843 if FLastError = 0 then
1844 InternalCreateSocket(Sin);
1845 end;
1846 end;
1847
1848 procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin);
1849 begin
1850 FStopFlag := False;
1851 FRecvCounter := 0;
1852 FSendCounter := 0;
1853 ResetLastError;
1854 if FSocket = INVALID_SOCKET then
1855 begin
1856 FBuffer := '';
1857 FBinded := False;
1858 FIP6Used := Sin.AddressFamily = AF_INET6;
1859 FSocket := synsock.Socket(integer(Sin.AddressFamily), GetSocketType, GetSocketProtocol);
1860 if FSocket = INVALID_SOCKET then
1861 FLastError := synsock.WSAGetLastError;
1862 {$IFNDEF CIL}
1863 FD_ZERO(FFDSet);
1864 FD_SET(FSocket, FFDSet);
1865 {$ENDIF}
1866 ExceptCheck;
1867 if FIP6used then
1868 DoStatus(HR_SocketCreate, 'IPv6')
1869 else
1870 DoStatus(HR_SocketCreate, 'IPv4');
1871 ProcessDelayedOptions;
1872 DoCreateSocket;
1873 end;
1874 end;
1875
1876 procedure TBlockSocket.CloseSocket;
1877 begin
1878 AbortSocket;
1879 end;
1880
1881 procedure TBlockSocket.AbortSocket;
1882 var
1883 n: integer;
1884 p: TSynaOption;
1885 begin
1886 if FSocket <> INVALID_SOCKET then
1887 synsock.CloseSocket(FSocket);
1888 FSocket := INVALID_SOCKET;
1889 for n := FDelayedOptions.Count - 1 downto 0 do
1890 begin
1891 p := TSynaOption(FDelayedOptions[n]);
1892 p.Free;
1893 end;
1894 FDelayedOptions.Clear;
1895 FFamily := FFamilySave;
1896 DoStatus(HR_SocketClose, '');
1897 end;
1898
1899 procedure TBlockSocket.Bind(IP, Port: string);
1900 var
1901 Sin: TVarSin;
1902 begin
1903 ResetLastError;
1904 if (FSocket <> INVALID_SOCKET)
1905 or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then
1906 begin
1907 SetSin(Sin, IP, Port);
1908 if FLastError = 0 then
1909 begin
1910 if FSocket = INVALID_SOCKET then
1911 InternalCreateSocket(Sin);
1912 SockCheck(synsock.Bind(FSocket, Sin));
1913 GetSinLocal;
1914 FBuffer := '';
1915 FBinded := True;
1916 end;
1917 ExceptCheck;
1918 DoStatus(HR_Bind, IP + ':' + Port);
1919 end;
1920 end;
1921
1922 procedure TBlockSocket.Connect(IP, Port: string);
1923 var
1924 Sin: TVarSin;
1925 b: boolean;
1926 begin
1927 SetSin(Sin, IP, Port);
1928 if FLastError = 0 then
1929 begin
1930 if FSocket = INVALID_SOCKET then
1931 InternalCreateSocket(Sin);
1932 if FConnectionTimeout > 0 then
1933 begin
1934 // connect in non-blocking mode
1935 b := NonBlockMode;
1936 NonBlockMode := true;
1937 SockCheck(synsock.Connect(FSocket, Sin));
1938 if (FLastError = WSAEINPROGRESS) OR (FLastError = WSAEWOULDBLOCK) then
1939 if not CanWrite(FConnectionTimeout) then
1940 FLastError := WSAETIMEDOUT;
1941 NonBlockMode := b;
1942 end
1943 else
1944 SockCheck(synsock.Connect(FSocket, Sin));
1945 if FLastError = 0 then
1946 GetSins;
1947 FBuffer := '';
1948 FLastCR := False;
1949 FLastLF := False;
1950 end;
1951 ExceptCheck;
1952 DoStatus(HR_Connect, IP + ':' + Port);
1953 end;
1954
1955 procedure TBlockSocket.Listen;
1956 begin
1957 SockCheck(synsock.Listen(FSocket, SOMAXCONN));
1958 GetSins;
1959 ExceptCheck;
1960 DoStatus(HR_Listen, '');
1961 end;
1962
Acceptnull1963 function TBlockSocket.Accept: TSocket;
1964 begin
1965 Result := synsock.Accept(FSocket, FRemoteSin);
1966 /// SockCheck(Result);
1967 ExceptCheck;
1968 DoStatus(HR_Accept, '');
1969 end;
1970
1971 procedure TBlockSocket.GetSinLocal;
1972 begin
1973 synsock.GetSockName(FSocket, FLocalSin);
1974 end;
1975
1976 procedure TBlockSocket.GetSinRemote;
1977 begin
1978 synsock.GetPeerName(FSocket, FRemoteSin);
1979 end;
1980
1981 procedure TBlockSocket.GetSins;
1982 begin
1983 GetSinLocal;
1984 GetSinRemote;
1985 end;
1986
1987 procedure TBlockSocket.SetBandwidth(Value: Integer);
1988 begin
1989 MaxSendBandwidth := Value;
1990 MaxRecvBandwidth := Value;
1991 end;
1992
1993 procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
1994 var
1995 x: LongWord;
1996 y: LongWord;
1997 n: integer;
1998 begin
1999 if FStopFlag then
2000 exit;
2001 if MaxB > 0 then
2002 begin
2003 y := GetTick;
2004 if Next > y then
2005 begin
2006 x := Next - y;
2007 if x > 0 then
2008 begin
2009 DoStatus(HR_Wait, IntToStr(x));
2010 sleep(x mod 250);
2011 for n := 1 to x div 250 do
2012 if FStopFlag then
2013 Break
2014 else
2015 sleep(250);
2016 end;
2017 end;
2018 Next := GetTick + Trunc((Length / MaxB) * 1000);
2019 end;
2020 end;
2021
TBlockSocket.TestStopFlagnull2022 function TBlockSocket.TestStopFlag: Boolean;
2023 begin
2024 DoHeartbeat;
2025 Result := FStopFlag;
2026 if Result then
2027 begin
2028 FStopFlag := False;
2029 FLastError := WSAECONNABORTED;
2030 ExceptCheck;
2031 end;
2032 end;
2033
2034
TBlockSocket.SendBuffernull2035 function TBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
2036 {$IFNDEF CIL}
2037 var
2038 x, y: integer;
2039 l, r: integer;
2040 p: Pointer;
2041 {$ENDIF}
2042 begin
2043 Result := 0;
2044 if TestStopFlag then
2045 Exit;
2046 DoMonitor(True, Buffer, Length);
2047 {$IFDEF CIL}
2048 Result := synsock.Send(FSocket, Buffer, Length, 0);
2049 {$ELSE}
2050 l := Length;
2051 x := 0;
2052 while x < l do
2053 begin
2054 y := l - x;
2055 if y > FSendMaxChunk then
2056 y := FSendMaxChunk;
2057 if y > 0 then
2058 begin
2059 LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
2060 p := IncPoint(Buffer, x);
2061 r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
2062 SockCheck(r);
2063 if FLastError = WSAEWOULDBLOCK then
2064 begin
2065 if CanWrite(FNonblockSendTimeout) then
2066 begin
2067 r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
2068 SockCheck(r);
2069 end
2070 else
2071 FLastError := WSAETIMEDOUT;
2072 end;
2073 if FLastError <> 0 then
2074 Break;
2075 Inc(x, r);
2076 Inc(Result, r);
2077 Inc(FSendCounter, r);
2078 DoStatus(HR_WriteCount, IntToStr(r));
2079 end
2080 else
2081 break;
2082 end;
2083 {$ENDIF}
2084 ExceptCheck;
2085 end;
2086
2087 procedure TBlockSocket.SendByte(Data: Byte);
2088 {$IFDEF CIL}
2089 var
2090 buf: TMemory;
2091 {$ENDIF}
2092 begin
2093 {$IFDEF CIL}
2094 setlength(buf, 1);
2095 buf[0] := Data;
2096 SendBuffer(buf, 1);
2097 {$ELSE}
2098 SendBuffer(@Data, 1);
2099 {$ENDIF}
2100 end;
2101
2102 procedure TBlockSocket.SendString(Data: AnsiString);
2103 var
2104 buf: TMemory;
2105 begin
2106 {$IFDEF CIL}
2107 buf := BytesOf(Data);
2108 {$ELSE}
2109 buf := Pointer(data);
2110 {$ENDIF}
2111 SendBuffer(buf, Length(Data));
2112 end;
2113
2114 procedure TBlockSocket.SendInteger(Data: integer);
2115 var
2116 buf: TMemory;
2117 begin
2118 {$IFDEF CIL}
2119 buf := System.BitConverter.GetBytes(Data);
2120 {$ELSE}
2121 buf := @Data;
2122 {$ENDIF}
2123 SendBuffer(buf, SizeOf(Data));
2124 end;
2125
2126 procedure TBlockSocket.SendBlock(const Data: AnsiString);
2127 var
2128 i: integer;
2129 begin
2130 i := SwapBytes(Length(data));
2131 SendString(Codelongint(i) + Data);
2132 end;
2133
2134 procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean);
2135 var
2136 l: integer;
2137 yr: integer;
2138 s: AnsiString;
2139 b: boolean;
2140 {$IFDEF CIL}
2141 buf: TMemory;
2142 {$ENDIF}
2143 begin
2144 b := true;
2145 l := 0;
2146 if WithSize then
2147 begin
2148 l := Stream.Size - Stream.Position;;
2149 if not Indy then
2150 l := synsock.HToNL(l);
2151 end;
2152 repeat
2153 {$IFDEF CIL}
2154 Setlength(buf, FSendMaxChunk);
2155 yr := Stream.read(buf, FSendMaxChunk);
2156 if yr > 0 then
2157 begin
2158 if WithSize and b then
2159 begin
2160 b := false;
2161 SendString(CodeLongInt(l));
2162 end;
2163 SendBuffer(buf, yr);
2164 if FLastError <> 0 then
2165 break;
2166 end
2167 {$ELSE}
2168 Setlength(s, FSendMaxChunk);
2169 yr := Stream.read(Pointer(s)^, FSendMaxChunk);
2170 if yr > 0 then
2171 begin
2172 SetLength(s, yr);
2173 if WithSize and b then
2174 begin
2175 b := false;
2176 SendString(CodeLongInt(l) + s);
2177 end
2178 else
2179 SendString(s);
2180 if FLastError <> 0 then
2181 break;
2182 end
2183 {$ENDIF}
2184 until yr <= 0;
2185 end;
2186
2187 procedure TBlockSocket.SendStreamRaw(const Stream: TStream);
2188 begin
2189 InternalSendStream(Stream, false, false);
2190 end;
2191
2192 procedure TBlockSocket.SendStreamIndy(const Stream: TStream);
2193 begin
2194 InternalSendStream(Stream, true, true);
2195 end;
2196
2197 procedure TBlockSocket.SendStream(const Stream: TStream);
2198 begin
2199 InternalSendStream(Stream, true, false);
2200 end;
2201
TBlockSocket.RecvBuffernull2202 function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer;
2203 begin
2204 Result := 0;
2205 if TestStopFlag then
2206 Exit;
2207 LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
2208 // Result := synsock.Recv(FSocket, Buffer^, Length, MSG_NOSIGNAL);
2209 Result := synsock.Recv(FSocket, Buffer, Length, MSG_NOSIGNAL);
2210 if Result = 0 then
2211 FLastError := WSAECONNRESET
2212 else
2213 SockCheck(Result);
2214 ExceptCheck;
2215 if Result > 0 then
2216 begin
2217 Inc(FRecvCounter, Result);
2218 DoStatus(HR_ReadCount, IntToStr(Result));
2219 DoMonitor(False, Buffer, Result);
2220 DoReadFilter(Buffer, Result);
2221 end;
2222 end;
2223
TBlockSocket.RecvBufferExnull2224 function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer;
2225 Timeout: Integer): Integer;
2226 var
2227 s: AnsiString;
2228 rl, l: integer;
2229 ti: LongWord;
2230 {$IFDEF CIL}
2231 n: integer;
2232 b: TMemory;
2233 {$ENDIF}
2234 begin
2235 ResetLastError;
2236 Result := 0;
2237 if Len > 0 then
2238 begin
2239 rl := 0;
2240 repeat
2241 ti := GetTick;
2242 s := RecvPacket(Timeout);
2243 l := Length(s);
2244 if (rl + l) > Len then
2245 l := Len - rl;
2246 {$IFDEF CIL}
2247 b := BytesOf(s);
2248 for n := 0 to l do
2249 Buffer[rl + n] := b[n];
2250 {$ELSE}
2251 Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
2252 {$ENDIF}
2253 rl := rl + l;
2254 if FLastError <> 0 then
2255 Break;
2256 if rl >= Len then
2257 Break;
2258 if not FInterPacketTimeout then
2259 begin
2260 Timeout := Timeout - integer(TickDelta(ti, GetTick));
2261 if Timeout <= 0 then
2262 begin
2263 FLastError := WSAETIMEDOUT;
2264 Break;
2265 end;
2266 end;
2267 until False;
2268 delete(s, 1, l);
2269 FBuffer := s;
2270 Result := rl;
2271 end;
2272 end;
2273
TBlockSocket.RecvBufferStrnull2274 function TBlockSocket.RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString;
2275 var
2276 x: integer;
2277 {$IFDEF CIL}
2278 buf: Tmemory;
2279 {$ENDIF}
2280 begin
2281 Result := '';
2282 if Len > 0 then
2283 begin
2284 {$IFDEF CIL}
2285 Setlength(Buf, Len);
2286 x := RecvBufferEx(buf, Len , Timeout);
2287 if FLastError = 0 then
2288 begin
2289 SetLength(Buf, x);
2290 Result := StringOf(buf);
2291 end
2292 else
2293 Result := '';
2294 {$ELSE}
2295 Setlength(Result, Len);
2296 x := RecvBufferEx(Pointer(Result), Len , Timeout);
2297 if FLastError = 0 then
2298 SetLength(Result, x)
2299 else
2300 Result := '';
2301 {$ENDIF}
2302 end;
2303 end;
2304
RecvPacketnull2305 function TBlockSocket.RecvPacket(Timeout: Integer): AnsiString;
2306 var
2307 x: integer;
2308 {$IFDEF CIL}
2309 buf: TMemory;
2310 {$ENDIF}
2311 begin
2312 Result := '';
2313 ResetLastError;
2314 if FBuffer <> '' then
2315 begin
2316 Result := FBuffer;
2317 FBuffer := '';
2318 end
2319 else
2320 begin
2321 {$IFDEF MSWINDOWS}
2322 //not drain CPU on large downloads...
2323 Sleep(0);
2324 {$ENDIF}
2325 x := WaitingData;
2326 if x > 0 then
2327 begin
2328 {$IFDEF CIL}
2329 SetLength(Buf, x);
2330 x := RecvBuffer(Buf, x);
2331 if x >= 0 then
2332 begin
2333 SetLength(Buf, x);
2334 Result := StringOf(Buf);
2335 end;
2336 {$ELSE}
2337 SetLength(Result, x);
2338 x := RecvBuffer(Pointer(Result), x);
2339 if x >= 0 then
2340 SetLength(Result, x);
2341 {$ENDIF}
2342 end
2343 else
2344 begin
2345 if CanRead(Timeout) then
2346 begin
2347 x := WaitingData;
2348 if x = 0 then
2349 FLastError := WSAECONNRESET;
2350 if x > 0 then
2351 begin
2352 {$IFDEF CIL}
2353 SetLength(Buf, x);
2354 x := RecvBuffer(Buf, x);
2355 if x >= 0 then
2356 begin
2357 SetLength(Buf, x);
2358 result := StringOf(Buf);
2359 end;
2360 {$ELSE}
2361 SetLength(Result, x);
2362 x := RecvBuffer(Pointer(Result), x);
2363 if x >= 0 then
2364 SetLength(Result, x);
2365 {$ENDIF}
2366 end;
2367 end
2368 else
2369 FLastError := WSAETIMEDOUT;
2370 end;
2371 end;
2372 if FConvertLineEnd and (Result <> '') then
2373 begin
2374 if FLastCR and (Result[1] = LF) then
2375 Delete(Result, 1, 1);
2376 if FLastLF and (Result[1] = CR) then
2377 Delete(Result, 1, 1);
2378 FLastCR := False;
2379 FLastLF := False;
2380 end;
2381 ExceptCheck;
2382 end;
2383
2384
TBlockSocket.RecvBytenull2385 function TBlockSocket.RecvByte(Timeout: Integer): Byte;
2386 begin
2387 Result := 0;
2388 ResetLastError;
2389 if FBuffer = '' then
2390 FBuffer := RecvPacket(Timeout);
2391 if (FLastError = 0) and (FBuffer <> '') then
2392 begin
2393 Result := Ord(FBuffer[1]);
2394 Delete(FBuffer, 1, 1);
2395 end;
2396 ExceptCheck;
2397 end;
2398
RecvIntegernull2399 function TBlockSocket.RecvInteger(Timeout: Integer): Integer;
2400 var
2401 s: AnsiString;
2402 begin
2403 Result := 0;
2404 s := RecvBufferStr(4, Timeout);
2405 if FLastError = 0 then
2406 Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
2407 end;
2408
RecvTerminatednull2409 function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString;
2410 var
2411 x: Integer;
2412 s: AnsiString;
2413 l: Integer;
2414 CorCRLF: Boolean;
2415 t: AnsiString;
2416 tl: integer;
2417 ti: LongWord;
2418 begin
2419 ResetLastError;
2420 Result := '';
2421 l := Length(Terminator);
2422 if l = 0 then
2423 Exit;
2424 tl := l;
2425 CorCRLF := FConvertLineEnd and (Terminator = CRLF);
2426 s := '';
2427 x := 0;
2428 repeat
2429 //get rest of FBuffer or incomming new data...
2430 ti := GetTick;
2431 s := s + RecvPacket(Timeout);
2432 if FLastError <> 0 then
2433 Break;
2434 x := 0;
2435 if Length(s) > 0 then
2436 if CorCRLF then
2437 begin
2438 t := '';
2439 x := PosCRLF(s, t);
2440 tl := Length(t);
2441 if t = CR then
2442 FLastCR := True;
2443 if t = LF then
2444 FLastLF := True;
2445 end
2446 else
2447 begin
2448 x := pos(Terminator, s);
2449 tl := l;
2450 end;
2451 if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then
2452 begin
2453 FLastError := WSAENOBUFS;
2454 Break;
2455 end;
2456 if x > 0 then
2457 Break;
2458 if not FInterPacketTimeout then
2459 begin
2460 Timeout := Timeout - integer(TickDelta(ti, GetTick));
2461 if Timeout <= 0 then
2462 begin
2463 FLastError := WSAETIMEDOUT;
2464 Break;
2465 end;
2466 end;
2467 until False;
2468 if x > 0 then
2469 begin
2470 Result := Copy(s, 1, x - 1);
2471 Delete(s, 1, x + tl - 1);
2472 end;
2473 FBuffer := s;
2474 ExceptCheck;
2475 end;
2476
RecvStringnull2477 function TBlockSocket.RecvString(Timeout: Integer): AnsiString;
2478 var
2479 s: AnsiString;
2480 begin
2481 Result := '';
2482 s := RecvTerminated(Timeout, CRLF);
2483 if FLastError = 0 then
2484 Result := s;
2485 end;
2486
TBlockSocket.RecvBlocknull2487 function TBlockSocket.RecvBlock(Timeout: Integer): AnsiString;
2488 var
2489 x: integer;
2490 begin
2491 Result := '';
2492 x := RecvInteger(Timeout);
2493 if FLastError = 0 then
2494 Result := RecvBufferStr(x, Timeout);
2495 end;
2496
2497 procedure TBlockSocket.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
2498 var
2499 s: AnsiString;
2500 begin
2501 repeat
2502 s := RecvPacket(Timeout);
2503 if FLastError = 0 then
2504 WriteStrToStream(Stream, s);
2505 until FLastError <> 0;
2506 end;
2507
2508 procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
2509 var
2510 s: AnsiString;
2511 n: integer;
2512 {$IFDEF CIL}
2513 buf: TMemory;
2514 {$ENDIF}
2515 begin
2516 for n := 1 to (Size div FSendMaxChunk) do
2517 begin
2518 {$IFDEF CIL}
2519 SetLength(buf, FSendMaxChunk);
2520 RecvBufferEx(buf, FSendMaxChunk, Timeout);
2521 if FLastError <> 0 then
2522 Exit;
2523 Stream.Write(buf, FSendMaxChunk);
2524 {$ELSE}
2525 s := RecvBufferStr(FSendMaxChunk, Timeout);
2526 if FLastError <> 0 then
2527 Exit;
2528 WriteStrToStream(Stream, s);
2529 {$ENDIF}
2530 end;
2531 n := Size mod FSendMaxChunk;
2532 if n > 0 then
2533 begin
2534 {$IFDEF CIL}
2535 SetLength(buf, n);
2536 RecvBufferEx(buf, n, Timeout);
2537 if FLastError <> 0 then
2538 Exit;
2539 Stream.Write(buf, n);
2540 {$ELSE}
2541 s := RecvBufferStr(n, Timeout);
2542 if FLastError <> 0 then
2543 Exit;
2544 WriteStrToStream(Stream, s);
2545 {$ENDIF}
2546 end;
2547 end;
2548
2549 procedure TBlockSocket.RecvStreamIndy(const Stream: TStream; Timeout: Integer);
2550 var
2551 x: integer;
2552 begin
2553 x := RecvInteger(Timeout);
2554 x := synsock.NToHL(x);
2555 if FLastError = 0 then
2556 RecvStreamSize(Stream, Timeout, x);
2557 end;
2558
2559 procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer);
2560 var
2561 x: integer;
2562 begin
2563 x := RecvInteger(Timeout);
2564 if FLastError = 0 then
2565 RecvStreamSize(Stream, Timeout, x);
2566 end;
2567
TBlockSocket.PeekBuffernull2568 function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer;
2569 begin
2570 {$IFNDEF CIL}
2571 // Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL);
2572 Result := synsock.Recv(FSocket, Buffer, Length, MSG_PEEK + MSG_NOSIGNAL);
2573 SockCheck(Result);
2574 ExceptCheck;
2575 {$ENDIF}
2576 end;
2577
PeekBytenull2578 function TBlockSocket.PeekByte(Timeout: Integer): Byte;
2579 var
2580 s: string;
2581 begin
2582 {$IFNDEF CIL}
2583 Result := 0;
2584 if CanRead(Timeout) then
2585 begin
2586 SetLength(s, 1);
2587 PeekBuffer(Pointer(s), 1);
2588 if s <> '' then
2589 Result := Ord(s[1]);
2590 end
2591 else
2592 FLastError := WSAETIMEDOUT;
2593 ExceptCheck;
2594 {$ENDIF}
2595 end;
2596
2597 procedure TBlockSocket.ResetLastError;
2598 begin
2599 FLastError := 0;
2600 FLastErrorDesc := '';
2601 end;
2602
SockChecknull2603 function TBlockSocket.SockCheck(SockResult: Integer): Integer;
2604 begin
2605 ResetLastError;
2606 if SockResult = integer(SOCKET_ERROR) then
2607 begin
2608 FLastError := synsock.WSAGetLastError;
2609 FLastErrorDesc := GetErrorDescEx;
2610 end;
2611 Result := FLastError;
2612 end;
2613
2614 procedure TBlockSocket.ExceptCheck;
2615 var
2616 e: ESynapseError;
2617 begin
2618 FLastErrorDesc := GetErrorDescEx;
2619 if (LastError <> 0) and (LastError <> WSAEINPROGRESS)
2620 and (LastError <> WSAEWOULDBLOCK) then
2621 begin
2622 DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc);
2623 if FRaiseExcept then
2624 begin
2625 e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s',
2626 [FLastError, FLastErrorDesc]));
2627 e.ErrorCode := FLastError;
2628 e.ErrorMessage := FLastErrorDesc;
2629 raise e;
2630 end;
2631 end;
2632 end;
2633
WaitingDatanull2634 function TBlockSocket.WaitingData: Integer;
2635 var
2636 x: Integer;
2637 begin
2638 Result := 0;
2639 if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then
2640 Result := x;
2641 if Result > c64k then
2642 Result := c64k;
2643 end;
2644
TBlockSocket.WaitingDataExnull2645 function TBlockSocket.WaitingDataEx: Integer;
2646 begin
2647 if FBuffer <> '' then
2648 Result := Length(FBuffer)
2649 else
2650 Result := WaitingData;
2651 end;
2652
2653 procedure TBlockSocket.Purge;
2654 begin
2655 Sleep(1);
2656 try
2657 while (Length(FBuffer) > 0) or (WaitingData > 0) do
2658 begin
2659 RecvPacket(0);
2660 if FLastError <> 0 then
2661 break;
2662 end;
2663 except
2664 on exception do;
2665 end;
2666 ResetLastError;
2667 end;
2668
2669 procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer);
2670 var
2671 d: TSynaOption;
2672 begin
2673 d := TSynaOption.Create;
2674 d.Option := SOT_Linger;
2675 d.Enabled := Enable;
2676 d.Value := Linger;
2677 DelayedOption(d);
2678 end;
2679
LocalNamenull2680 function TBlockSocket.LocalName: string;
2681 begin
2682 Result := synsock.GetHostName;
2683 if Result = '' then
2684 Result := '127.0.0.1';
2685 end;
2686
2687 procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings);
2688 begin
2689 IPList.Clear;
2690 synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList);
2691 if IPList.Count = 0 then
2692 IPList.Add(cAnyHost);
2693 end;
2694
TBlockSocket.ResolveNamenull2695 function TBlockSocket.ResolveName(Name: string): string;
2696 var
2697 l: TStringList;
2698 begin
2699 l := TStringList.Create;
2700 try
2701 ResolveNameToIP(Name, l);
2702 Result := l[0];
2703 finally
2704 l.Free;
2705 end;
2706 end;
2707
ResolvePortnull2708 function TBlockSocket.ResolvePort(Port: string): Word;
2709 begin
2710 Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
2711 end;
2712
ResolveIPToNamenull2713 function TBlockSocket.ResolveIPToName(IP: string): string;
2714 begin
2715 if not IsIP(IP) and not IsIp6(IP) then
2716 IP := ResolveName(IP);
2717 Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
2718 end;
2719
2720 procedure TBlockSocket.SetRemoteSin(IP, Port: string);
2721 begin
2722 SetSin(FRemoteSin, IP, Port);
2723 end;
2724
TBlockSocket.GetLocalSinIPnull2725 function TBlockSocket.GetLocalSinIP: string;
2726 begin
2727 Result := GetSinIP(FLocalSin);
2728 end;
2729
GetRemoteSinIPnull2730 function TBlockSocket.GetRemoteSinIP: string;
2731 begin
2732 Result := GetSinIP(FRemoteSin);
2733 end;
2734
TBlockSocket.GetLocalSinPortnull2735 function TBlockSocket.GetLocalSinPort: Integer;
2736 begin
2737 Result := GetSinPort(FLocalSin);
2738 end;
2739
TBlockSocket.GetRemoteSinPortnull2740 function TBlockSocket.GetRemoteSinPort: Integer;
2741 begin
2742 Result := GetSinPort(FRemoteSin);
2743 end;
2744
InternalCanReadnull2745 function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean;
2746 {$IFDEF CIL}
2747 begin
2748 Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead);
2749 {$ELSE}
2750 var
2751 TimeVal: PTimeVal;
2752 TimeV: TTimeVal;
2753 x: Integer;
2754 FDSet: TFDSet;
2755 begin
2756 TimeV.tv_usec := (Timeout mod 1000) * 1000;
2757 TimeV.tv_sec := Timeout div 1000;
2758 TimeVal := @TimeV;
2759 if Timeout = -1 then
2760 TimeVal := nil;
2761 FDSet := FFdSet;
2762 x := synsock.Select(FSocket + 1, @FDSet, nil, nil, TimeVal);
2763 SockCheck(x);
2764 if FLastError <> 0 then
2765 x := 0;
2766 Result := x > 0;
2767 {$ENDIF}
2768 end;
2769
CanReadnull2770 function TBlockSocket.CanRead(Timeout: Integer): Boolean;
2771 var
2772 ti, tr: Integer;
2773 n: integer;
2774 begin
2775 if (FHeartbeatRate <> 0) and (Timeout <> -1) then
2776 begin
2777 ti := Timeout div FHeartbeatRate;
2778 tr := Timeout mod FHeartbeatRate;
2779 end
2780 else
2781 begin
2782 ti := 0;
2783 tr := Timeout;
2784 end;
2785 Result := InternalCanRead(tr);
2786 if not Result then
2787 for n := 0 to ti do
2788 begin
2789 DoHeartbeat;
2790 if FStopFlag then
2791 begin
2792 Result := False;
2793 FStopFlag := False;
2794 Break;
2795 end;
2796 Result := InternalCanRead(FHeartbeatRate);
2797 if Result then
2798 break;
2799 end;
2800 ExceptCheck;
2801 if Result then
2802 DoStatus(HR_CanRead, '');
2803 end;
2804
TBlockSocket.InternalCanWritenull2805 function TBlockSocket.InternalCanWrite(Timeout: Integer): Boolean;
2806 {$IFDEF CIL}
2807 begin
2808 Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectWrite);
2809 {$ELSE}
2810 var
2811 TimeVal: PTimeVal;
2812 TimeV: TTimeVal;
2813 x: Integer;
2814 FDSet: TFDSet;
2815 begin
2816 TimeV.tv_usec := (Timeout mod 1000) * 1000;
2817 TimeV.tv_sec := Timeout div 1000;
2818 TimeVal := @TimeV;
2819 if Timeout = -1 then
2820 TimeVal := nil;
2821 FDSet := FFdSet;
2822 x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal);
2823 SockCheck(x);
2824 if FLastError <> 0 then
2825 x := 0;
2826 Result := x > 0;
2827 {$ENDIF}
2828 end;
2829
CanWritenull2830 function TBlockSocket.CanWrite(Timeout: Integer): Boolean;
2831 var
2832 ti, tr: Integer;
2833 n: integer;
2834 begin
2835 if (FHeartbeatRate <> 0) and (Timeout <> -1) then
2836 begin
2837 ti := Timeout div FHeartbeatRate;
2838 tr := Timeout mod FHeartbeatRate;
2839 end
2840 else
2841 begin
2842 ti := 0;
2843 tr := Timeout;
2844 end;
2845 Result := InternalCanWrite(tr);
2846 if not Result then
2847 for n := 0 to ti do
2848 begin
2849 DoHeartbeat;
2850 if FStopFlag then
2851 begin
2852 Result := False;
2853 FStopFlag := False;
2854 Break;
2855 end;
2856 Result := InternalCanWrite(FHeartbeatRate);
2857 if Result then
2858 break;
2859 end;
2860 ExceptCheck;
2861 if Result then
2862 DoStatus(HR_CanWrite, '');
2863 end;
2864
TBlockSocket.CanReadExnull2865 function TBlockSocket.CanReadEx(Timeout: Integer): Boolean;
2866 begin
2867 if FBuffer <> '' then
2868 Result := True
2869 else
2870 Result := CanRead(Timeout);
2871 end;
2872
TBlockSocket.SendBufferTonull2873 function TBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer;
2874 begin
2875 Result := 0;
2876 if TestStopFlag then
2877 Exit;
2878 DoMonitor(True, Buffer, Length);
2879 LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
2880 Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin);
2881 SockCheck(Result);
2882 ExceptCheck;
2883 Inc(FSendCounter, Result);
2884 DoStatus(HR_WriteCount, IntToStr(Result));
2885 end;
2886
TBlockSocket.RecvBufferFromnull2887 function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer;
2888 begin
2889 Result := 0;
2890 if TestStopFlag then
2891 Exit;
2892 LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
2893 Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin);
2894 SockCheck(Result);
2895 ExceptCheck;
2896 Inc(FRecvCounter, Result);
2897 DoStatus(HR_ReadCount, IntToStr(Result));
2898 DoMonitor(False, Buffer, Result);
2899 end;
2900
GetSizeRecvBuffernull2901 function TBlockSocket.GetSizeRecvBuffer: Integer;
2902 var
2903 l: Integer;
2904 {$IFDEF CIL}
2905 buf: TMemory;
2906 {$ENDIF}
2907 begin
2908 {$IFDEF CIL}
2909 setlength(buf, 4);
2910 SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), buf, l));
2911 Result := System.BitConverter.ToInt32(buf,0);
2912 {$ELSE}
2913 l := SizeOf(Result);
2914 SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l));
2915 if FLastError <> 0 then
2916 Result := 1024;
2917 ExceptCheck;
2918 {$ENDIF}
2919 end;
2920
2921 procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer);
2922 var
2923 d: TSynaOption;
2924 begin
2925 d := TSynaOption.Create;
2926 d.Option := SOT_RecvBuff;
2927 d.Value := Size;
2928 DelayedOption(d);
2929 end;
2930
GetSizeSendBuffernull2931 function TBlockSocket.GetSizeSendBuffer: Integer;
2932 var
2933 l: Integer;
2934 {$IFDEF CIL}
2935 buf: TMemory;
2936 {$ENDIF}
2937 begin
2938 {$IFDEF CIL}
2939 setlength(buf, 4);
2940 SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), buf, l));
2941 Result := System.BitConverter.ToInt32(buf,0);
2942 {$ELSE}
2943 l := SizeOf(Result);
2944 SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l));
2945 if FLastError <> 0 then
2946 Result := 1024;
2947 ExceptCheck;
2948 {$ENDIF}
2949 end;
2950
2951 procedure TBlockSocket.SetSizeSendBuffer(Size: Integer);
2952 var
2953 d: TSynaOption;
2954 begin
2955 d := TSynaOption.Create;
2956 d.Option := SOT_SendBuff;
2957 d.Value := Size;
2958 DelayedOption(d);
2959 end;
2960
2961 procedure TBlockSocket.SetNonBlockMode(Value: Boolean);
2962 var
2963 d: TSynaOption;
2964 begin
2965 d := TSynaOption.Create;
2966 d.Option := SOT_nonblock;
2967 d.Enabled := Value;
2968 DelayedOption(d);
2969 end;
2970
2971 procedure TBlockSocket.SetTimeout(Timeout: Integer);
2972 begin
2973 SetSendTimeout(Timeout);
2974 SetRecvTimeout(Timeout);
2975 end;
2976
2977 procedure TBlockSocket.SetSendTimeout(Timeout: Integer);
2978 var
2979 d: TSynaOption;
2980 begin
2981 d := TSynaOption.Create;
2982 d.Option := SOT_sendtimeout;
2983 d.Value := Timeout;
2984 DelayedOption(d);
2985 end;
2986
2987 procedure TBlockSocket.SetRecvTimeout(Timeout: Integer);
2988 var
2989 d: TSynaOption;
2990 begin
2991 d := TSynaOption.Create;
2992 d.Option := SOT_recvtimeout;
2993 d.Value := Timeout;
2994 DelayedOption(d);
2995 end;
2996
2997 {$IFNDEF CIL}
TBlockSocket.GroupCanReadnull2998 function TBlockSocket.GroupCanRead(const SocketList: TList; Timeout: Integer;
2999 const CanReadList: TList): boolean;
3000 var
3001 FDSet: TFDSet;
3002 TimeVal: PTimeVal;
3003 TimeV: TTimeVal;
3004 x, n: Integer;
3005 Max: Integer;
3006 begin
3007 TimeV.tv_usec := (Timeout mod 1000) * 1000;
3008 TimeV.tv_sec := Timeout div 1000;
3009 TimeVal := @TimeV;
3010 if Timeout = -1 then
3011 TimeVal := nil;
3012 FD_ZERO(FDSet);
3013 Max := 0;
3014 for n := 0 to SocketList.Count - 1 do
3015 if TObject(SocketList.Items[n]) is TBlockSocket then
3016 begin
3017 if TBlockSocket(SocketList.Items[n]).Socket > Max then
3018 Max := TBlockSocket(SocketList.Items[n]).Socket;
3019 FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet);
3020 end;
3021 x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal);
3022 SockCheck(x);
3023 ExceptCheck;
3024 if FLastError <> 0 then
3025 x := 0;
3026 Result := x > 0;
3027 CanReadList.Clear;
3028 if Result then
3029 for n := 0 to SocketList.Count - 1 do
3030 if TObject(SocketList.Items[n]) is TBlockSocket then
3031 if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then
3032 CanReadList.Add(TBlockSocket(SocketList.Items[n]));
3033 end;
3034 {$ENDIF}
3035
3036 procedure TBlockSocket.EnableReuse(Value: Boolean);
3037 var
3038 d: TSynaOption;
3039 begin
3040 d := TSynaOption.Create;
3041 d.Option := SOT_reuse;
3042 d.Enabled := Value;
3043 DelayedOption(d);
3044 end;
3045
3046 procedure TBlockSocket.SetTTL(TTL: integer);
3047 var
3048 d: TSynaOption;
3049 begin
3050 d := TSynaOption.Create;
3051 d.Option := SOT_TTL;
3052 d.Value := TTL;
3053 DelayedOption(d);
3054 end;
3055
GetTTLnull3056 function TBlockSocket.GetTTL:integer;
3057 var
3058 l: Integer;
3059 begin
3060 {$IFNDEF CIL}
3061 l := SizeOf(Result);
3062 if FIP6Used then
3063 synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, @Result, l)
3064 else
3065 synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l);
3066 {$ENDIF}
3067 end;
3068
3069 procedure TBlockSocket.SetFamily(Value: TSocketFamily);
3070 begin
3071 FFamily := Value;
3072 FFamilySave := Value;
3073 end;
3074
3075 procedure TBlockSocket.SetSocket(Value: TSocket);
3076 begin
3077 FRecvCounter := 0;
3078 FSendCounter := 0;
3079 FSocket := Value;
3080 {$IFNDEF CIL}
3081 FD_ZERO(FFDSet);
3082 FD_SET(FSocket, FFDSet);
3083 {$ENDIF}
3084 GetSins;
3085 FIP6Used := FRemoteSin.AddressFamily = AF_INET6;
3086 end;
3087
GetWsaDatanull3088 function TBlockSocket.GetWsaData: TWSAData;
3089 begin
3090 {$IFDEF ONCEWINSOCK}
3091 Result := WsaDataOnce;
3092 {$ELSE}
3093 Result := FWsaDataOnce;
3094 {$ENDIF}
3095 end;
3096
TBlockSocket.GetSocketTypenull3097 function TBlockSocket.GetSocketType: integer;
3098 begin
3099 Result := 0;
3100 end;
3101
GetSocketProtocolnull3102 function TBlockSocket.GetSocketProtocol: integer;
3103 begin
3104 Result := integer(IPPROTO_IP);
3105 end;
3106
3107 procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string);
3108 begin
3109 if assigned(OnStatus) then
3110 OnStatus(Self, Reason, Value);
3111 end;
3112
3113 procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer);
3114 var
3115 s: AnsiString;
3116 begin
3117 if assigned(OnReadFilter) then
3118 if Len > 0 then
3119 begin
3120 {$IFDEF CIL}
3121 s := StringOf(Buffer);
3122 {$ELSE}
3123 SetLength(s, Len);
3124 Move(Buffer^, Pointer(s)^, Len);
3125 {$ENDIF}
3126 OnReadFilter(Self, s);
3127 if Length(s) > Len then
3128 SetLength(s, Len);
3129 Len := Length(s);
3130 {$IFDEF CIL}
3131 Buffer := BytesOf(s);
3132 {$ELSE}
3133 Move(Pointer(s)^, Buffer^, Len);
3134 {$ENDIF}
3135 end;
3136 end;
3137
3138 procedure TBlockSocket.DoCreateSocket;
3139 begin
3140 if assigned(OnCreateSocket) then
3141 OnCreateSocket(Self);
3142 end;
3143
3144 procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
3145 begin
3146 if assigned(OnMonitor) then
3147 begin
3148 OnMonitor(Self, Writing, Buffer, Len);
3149 end;
3150 end;
3151
3152 procedure TBlockSocket.DoHeartbeat;
3153 begin
3154 if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then
3155 begin
3156 OnHeartbeat(Self);
3157 end;
3158 end;
3159
TBlockSocket.GetErrorDescExnull3160 function TBlockSocket.GetErrorDescEx: string;
3161 begin
3162 Result := GetErrorDesc(FLastError);
3163 end;
3164
TBlockSocket.GetErrorDescnull3165 class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string;
3166 begin
3167 {$IFDEF CIL}
3168 if ErrorCode = 0 then
3169 Result := ''
3170 else
3171 begin
3172 Result := WSAGetLastErrorDesc;
3173 if Result = '' then
3174 Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')';
3175 end;
3176 {$ELSE}
3177 case ErrorCode of
3178 0:
3179 Result := '';
3180 WSAEINTR: {10004}
3181 Result := 'Interrupted system call';
3182 WSAEBADF: {10009}
3183 Result := 'Bad file number';
3184 WSAEACCES: {10013}
3185 Result := 'Permission denied';
3186 WSAEFAULT: {10014}
3187 Result := 'Bad address';
3188 WSAEINVAL: {10022}
3189 Result := 'Invalid argument';
3190 WSAEMFILE: {10024}
3191 Result := 'Too many open files';
3192 WSAEWOULDBLOCK: {10035}
3193 Result := 'Operation would block';
3194 WSAEINPROGRESS: {10036}
3195 Result := 'Operation now in progress';
3196 WSAEALREADY: {10037}
3197 Result := 'Operation already in progress';
3198 WSAENOTSOCK: {10038}
3199 Result := 'Socket operation on nonsocket';
3200 WSAEDESTADDRREQ: {10039}
3201 Result := 'Destination address required';
3202 WSAEMSGSIZE: {10040}
3203 Result := 'Message too long';
3204 WSAEPROTOTYPE: {10041}
3205 Result := 'Protocol wrong type for Socket';
3206 WSAENOPROTOOPT: {10042}
3207 Result := 'Protocol not available';
3208 WSAEPROTONOSUPPORT: {10043}
3209 Result := 'Protocol not supported';
3210 WSAESOCKTNOSUPPORT: {10044}
3211 Result := 'Socket not supported';
3212 WSAEOPNOTSUPP: {10045}
3213 Result := 'Operation not supported on Socket';
3214 WSAEPFNOSUPPORT: {10046}
3215 Result := 'Protocol family not supported';
3216 WSAEAFNOSUPPORT: {10047}
3217 Result := 'Address family not supported';
3218 WSAEADDRINUSE: {10048}
3219 Result := 'Address already in use';
3220 WSAEADDRNOTAVAIL: {10049}
3221 Result := 'Can''t assign requested address';
3222 WSAENETDOWN: {10050}
3223 Result := 'Network is down';
3224 WSAENETUNREACH: {10051}
3225 Result := 'Network is unreachable';
3226 WSAENETRESET: {10052}
3227 Result := 'Network dropped connection on reset';
3228 WSAECONNABORTED: {10053}
3229 Result := 'Software caused connection abort';
3230 WSAECONNRESET: {10054}
3231 Result := 'Connection reset by peer';
3232 WSAENOBUFS: {10055}
3233 Result := 'No Buffer space available';
3234 WSAEISCONN: {10056}
3235 Result := 'Socket is already connected';
3236 WSAENOTCONN: {10057}
3237 Result := 'Socket is not connected';
3238 WSAESHUTDOWN: {10058}
3239 Result := 'Can''t send after Socket shutdown';
3240 WSAETOOMANYREFS: {10059}
3241 Result := 'Too many references:can''t splice';
3242 WSAETIMEDOUT: {10060}
3243 Result := 'Connection timed out';
3244 WSAECONNREFUSED: {10061}
3245 Result := 'Connection refused';
3246 WSAELOOP: {10062}
3247 Result := 'Too many levels of symbolic links';
3248 WSAENAMETOOLONG: {10063}
3249 Result := 'File name is too long';
3250 WSAEHOSTDOWN: {10064}
3251 Result := 'Host is down';
3252 WSAEHOSTUNREACH: {10065}
3253 Result := 'No route to host';
3254 WSAENOTEMPTY: {10066}
3255 Result := 'Directory is not empty';
3256 WSAEPROCLIM: {10067}
3257 Result := 'Too many processes';
3258 WSAEUSERS: {10068}
3259 Result := 'Too many users';
3260 WSAEDQUOT: {10069}
3261 Result := 'Disk quota exceeded';
3262 WSAESTALE: {10070}
3263 Result := 'Stale NFS file handle';
3264 WSAEREMOTE: {10071}
3265 Result := 'Too many levels of remote in path';
3266 WSASYSNOTREADY: {10091}
3267 Result := 'Network subsystem is unusable';
3268 WSAVERNOTSUPPORTED: {10092}
3269 Result := 'Winsock DLL cannot support this application';
3270 WSANOTINITIALISED: {10093}
3271 Result := 'Winsock not initialized';
3272 WSAEDISCON: {10101}
3273 Result := 'Disconnect';
3274 WSAHOST_NOT_FOUND: {11001}
3275 Result := 'Host not found';
3276 WSATRY_AGAIN: {11002}
3277 Result := 'Non authoritative - host not found';
3278 WSANO_RECOVERY: {11003}
3279 Result := 'Non recoverable error';
3280 WSANO_DATA: {11004}
3281 Result := 'Valid name, no data record of requested type'
3282 else
3283 Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')';
3284 end;
3285 {$ENDIF}
3286 end;
3287
3288 {======================================================================}
3289
3290 constructor TSocksBlockSocket.Create;
3291 begin
3292 inherited Create;
3293 FSocksIP:= '';
3294 FSocksPort:= '1080';
3295 FSocksTimeout:= 60000;
3296 FSocksUsername:= '';
3297 FSocksPassword:= '';
3298 FUsingSocks := False;
3299 FSocksResolver := True;
3300 FSocksLastError := 0;
3301 FSocksResponseIP := '';
3302 FSocksResponsePort := '';
3303 FSocksLocalIP := '';
3304 FSocksLocalPort := '';
3305 FSocksRemoteIP := '';
3306 FSocksRemotePort := '';
3307 FBypassFlag := False;
3308 FSocksType := ST_Socks5;
3309 end;
3310
SocksOpennull3311 function TSocksBlockSocket.SocksOpen: boolean;
3312 var
3313 Buf: AnsiString;
3314 n: integer;
3315 begin
3316 Result := False;
3317 FUsingSocks := False;
3318 if FSocksType <> ST_Socks5 then
3319 begin
3320 FUsingSocks := True;
3321 Result := True;
3322 end
3323 else
3324 begin
3325 FBypassFlag := True;
3326 try
3327 if FSocksUsername = '' then
3328 Buf := #5 + #1 + #0
3329 else
3330 Buf := #5 + #2 + #2 +#0;
3331 SendString(Buf);
3332 Buf := RecvBufferStr(2, FSocksTimeout);
3333 if Length(Buf) < 2 then
3334 Exit;
3335 if Buf[1] <> #5 then
3336 Exit;
3337 n := Ord(Buf[2]);
3338 case n of
3339 0: //not need authorisation
3340 ;
3341 2:
3342 begin
3343 Buf := #1 + AnsiChar(Length(FSocksUsername)) + FSocksUsername
3344 + AnsiChar(Length(FSocksPassword)) + FSocksPassword;
3345 SendString(Buf);
3346 Buf := RecvBufferStr(2, FSocksTimeout);
3347 if Length(Buf) < 2 then
3348 Exit;
3349 if Buf[2] <> #0 then
3350 Exit;
3351 end;
3352 else
3353 //other authorisation is not supported!
3354 Exit;
3355 end;
3356 FUsingSocks := True;
3357 Result := True;
3358 finally
3359 FBypassFlag := False;
3360 end;
3361 end;
3362 end;
3363
SocksRequestnull3364 function TSocksBlockSocket.SocksRequest(Cmd: Byte;
3365 const IP, Port: string): Boolean;
3366 var
3367 Buf: AnsiString;
3368 begin
3369 FBypassFlag := True;
3370 try
3371 if FSocksType <> ST_Socks5 then
3372 Buf := #4 + AnsiChar(Cmd) + SocksCode(IP, Port)
3373 else
3374 Buf := #5 + AnsiChar(Cmd) + #0 + SocksCode(IP, Port);
3375 SendString(Buf);
3376 Result := FLastError = 0;
3377 finally
3378 FBypassFlag := False;
3379 end;
3380 end;
3381
TSocksBlockSocket.SocksResponsenull3382 function TSocksBlockSocket.SocksResponse: Boolean;
3383 var
3384 Buf, s: AnsiString;
3385 x: integer;
3386 begin
3387 Result := False;
3388 FBypassFlag := True;
3389 try
3390 FSocksResponseIP := '';
3391 FSocksResponsePort := '';
3392 FSocksLastError := -1;
3393 if FSocksType <> ST_Socks5 then
3394 begin
3395 Buf := RecvBufferStr(8, FSocksTimeout);
3396 if FLastError <> 0 then
3397 Exit;
3398 if Buf[1] <> #0 then
3399 Exit;
3400 FSocksLastError := Ord(Buf[2]);
3401 end
3402 else
3403 begin
3404 Buf := RecvBufferStr(4, FSocksTimeout);
3405 if FLastError <> 0 then
3406 Exit;
3407 if Buf[1] <> #5 then
3408 Exit;
3409 case Ord(Buf[4]) of
3410 1:
3411 s := RecvBufferStr(4, FSocksTimeout);
3412 3:
3413 begin
3414 x := RecvByte(FSocksTimeout);
3415 if FLastError <> 0 then
3416 Exit;
3417 s := AnsiChar(x) + RecvBufferStr(x, FSocksTimeout);
3418 end;
3419 4:
3420 s := RecvBufferStr(16, FSocksTimeout);
3421 else
3422 Exit;
3423 end;
3424 Buf := Buf + s + RecvBufferStr(2, FSocksTimeout);
3425 if FLastError <> 0 then
3426 Exit;
3427 FSocksLastError := Ord(Buf[2]);
3428 end;
3429 if ((FSocksLastError <> 0) and (FSocksLastError <> 90)) then
3430 Exit;
3431 SocksDecode(Buf);
3432 Result := True;
3433 finally
3434 FBypassFlag := False;
3435 end;
3436 end;
3437
TSocksBlockSocket.SocksCodenull3438 function TSocksBlockSocket.SocksCode(IP, Port: string): Ansistring;
3439 var
3440 ip6: TIp6Bytes;
3441 n: integer;
3442 begin
3443 if FSocksType <> ST_Socks5 then
3444 begin
3445 Result := CodeInt(ResolvePort(Port));
3446 if not FSocksResolver then
3447 IP := ResolveName(IP);
3448 if IsIP(IP) then
3449 begin
3450 Result := Result + IPToID(IP);
3451 Result := Result + FSocksUsername + #0;
3452 end
3453 else
3454 begin
3455 Result := Result + IPToID('0.0.0.1');
3456 Result := Result + FSocksUsername + #0;
3457 Result := Result + IP + #0;
3458 end;
3459 end
3460 else
3461 begin
3462 if not FSocksResolver then
3463 IP := ResolveName(IP);
3464 if IsIP(IP) then
3465 Result := #1 + IPToID(IP)
3466 else
3467 if IsIP6(IP) then
3468 begin
3469 ip6 := StrToIP6(IP);
3470 Result := #4;
3471 for n := 0 to 15 do
3472 Result := Result + AnsiChar(ip6[n]);
3473 end
3474 else
3475 Result := #3 + AnsiChar(Length(IP)) + IP;
3476 Result := Result + CodeInt(ResolvePort(Port));
3477 end;
3478 end;
3479
SocksDecodenull3480 function TSocksBlockSocket.SocksDecode(Value: Ansistring): integer;
3481 var
3482 Atyp: Byte;
3483 y, n: integer;
3484 w: Word;
3485 ip6: TIp6Bytes;
3486 begin
3487 FSocksResponsePort := '0';
3488 Result := 0;
3489 if FSocksType <> ST_Socks5 then
3490 begin
3491 if Length(Value) < 8 then
3492 Exit;
3493 Result := 3;
3494 w := DecodeInt(Value, Result);
3495 FSocksResponsePort := IntToStr(w);
3496 FSocksResponseIP := Format('%d.%d.%d.%d',
3497 [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]);
3498 Result := 9;
3499 end
3500 else
3501 begin
3502 if Length(Value) < 4 then
3503 Exit;
3504 Atyp := Ord(Value[4]);
3505 Result := 5;
3506 case Atyp of
3507 1:
3508 begin
3509 if Length(Value) < 10 then
3510 Exit;
3511 FSocksResponseIP := Format('%d.%d.%d.%d',
3512 [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]);
3513 Result := 9;
3514 end;
3515 3:
3516 begin
3517 y := Ord(Value[5]);
3518 if Length(Value) < (5 + y + 2) then
3519 Exit;
3520 for n := 6 to 6 + y - 1 do
3521 FSocksResponseIP := FSocksResponseIP + Value[n];
3522 Result := 5 + y + 1;
3523 end;
3524 4:
3525 begin
3526 if Length(Value) < 22 then
3527 Exit;
3528 for n := 0 to 15 do
3529 ip6[n] := ord(Value[n + 5]);
3530 FSocksResponseIP := IP6ToStr(ip6);
3531 Result := 21;
3532 end;
3533 else
3534 Exit;
3535 end;
3536 w := DecodeInt(Value, Result);
3537 FSocksResponsePort := IntToStr(w);
3538 Result := Result + 2;
3539 end;
3540 end;
3541
3542 {======================================================================}
3543
3544 procedure TDgramBlockSocket.Connect(IP, Port: string);
3545 begin
3546 SetRemoteSin(IP, Port);
3547 InternalCreateSocket(FRemoteSin);
3548 FBuffer := '';
3549 DoStatus(HR_Connect, IP + ':' + Port);
3550 end;
3551
RecvBuffernull3552 function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer;
3553 begin
3554 Result := RecvBufferFrom(Buffer, Length);
3555 end;
3556
TDgramBlockSocket.SendBuffernull3557 function TDgramBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
3558 begin
3559 Result := SendBufferTo(Buffer, Length);
3560 end;
3561
3562 {======================================================================}
3563
3564 destructor TUDPBlockSocket.Destroy;
3565 begin
3566 if Assigned(FSocksControlSock) then
3567 FSocksControlSock.Free;
3568 inherited;
3569 end;
3570
3571 procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean);
3572 var
3573 d: TSynaOption;
3574 begin
3575 d := TSynaOption.Create;
3576 d.Option := SOT_Broadcast;
3577 d.Enabled := Value;
3578 DelayedOption(d);
3579 end;
3580
TUDPBlockSocket.UdpAssociationnull3581 function TUDPBlockSocket.UdpAssociation: Boolean;
3582 var
3583 b: Boolean;
3584 begin
3585 Result := True;
3586 FUsingSocks := False;
3587 if FSocksIP <> '' then
3588 begin
3589 Result := False;
3590 if not Assigned(FSocksControlSock) then
3591 FSocksControlSock := TTCPBlockSocket.Create;
3592 FSocksControlSock.CloseSocket;
3593 FSocksControlSock.CreateSocketByName(FSocksIP);
3594 FSocksControlSock.Connect(FSocksIP, FSocksPort);
3595 if FSocksControlSock.LastError <> 0 then
3596 Exit;
3597 // if not assigned local port, assign it!
3598 if not FBinded then
3599 Bind(cAnyHost, cAnyPort);
3600 //open control TCP connection to SOCKS
3601 FSocksControlSock.FSocksUsername := FSocksUsername;
3602 FSocksControlSock.FSocksPassword := FSocksPassword;
3603 b := FSocksControlSock.SocksOpen;
3604 if b then
3605 b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort));
3606 if b then
3607 b := FSocksControlSock.SocksResponse;
3608 if not b and (FLastError = 0) then
3609 FLastError := WSANO_RECOVERY;
3610 FUsingSocks :=FSocksControlSock.UsingSocks;
3611 FSocksRemoteIP := FSocksControlSock.FSocksResponseIP;
3612 FSocksRemotePort := FSocksControlSock.FSocksResponsePort;
3613 Result := b and (FLastError = 0);
3614 end;
3615 end;
3616
TUDPBlockSocket.SendBufferTonull3617 function TUDPBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer;
3618 var
3619 SIp: string;
3620 SPort: integer;
3621 Buf: Ansistring;
3622 begin
3623 Result := 0;
3624 FUsingSocks := False;
3625 if (FSocksIP <> '') and (not UdpAssociation) then
3626 FLastError := WSANO_RECOVERY
3627 else
3628 begin
3629 if FUsingSocks then
3630 begin
3631 {$IFNDEF CIL}
3632 Sip := GetRemoteSinIp;
3633 SPort := GetRemoteSinPort;
3634 SetRemoteSin(FSocksRemoteIP, FSocksRemotePort);
3635 SetLength(Buf,Length);
3636 Move(Buffer^, Pointer(Buf)^, Length);
3637 Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf;
3638 Result := inherited SendBufferTo(Pointer(Buf), System.Length(buf));
3639 SetRemoteSin(Sip, IntToStr(SPort));
3640 {$ENDIF}
3641 end
3642 else
3643 Result := inherited SendBufferTo(Buffer, Length);
3644 end;
3645 end;
3646
RecvBufferFromnull3647 function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer;
3648 var
3649 Buf: Ansistring;
3650 x: integer;
3651 begin
3652 Result := inherited RecvBufferFrom(Buffer, Length);
3653 if FUsingSocks then
3654 begin
3655 {$IFNDEF CIL}
3656 SetLength(Buf, Result);
3657 Move(Buffer^, Pointer(Buf)^, Result);
3658 x := SocksDecode(Buf);
3659 Result := Result - x + 1;
3660 Buf := Copy(Buf, x, Result);
3661 Move(Pointer(Buf)^, Buffer^, Result);
3662 SetRemoteSin(FSocksResponseIP, FSocksResponsePort);
3663 {$ENDIF}
3664 end;
3665 end;
3666
3667 {$IFNDEF CIL}
3668 procedure TUDPBlockSocket.AddMulticast(MCastIP: string);
3669 var
3670 Multicast: TIP_mreq;
3671 Multicast6: TIPv6_mreq;
3672 n: integer;
3673 ip6: Tip6bytes;
3674 begin
3675 if FIP6Used then
3676 begin
3677 ip6 := StrToIp6(MCastIP);
3678 for n := 0 to 15 do
3679 Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
3680 Multicast6.ipv6mr_interface := 0;
3681 SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP,
3682 PAnsiChar(@Multicast6), SizeOf(Multicast6)));
3683 end
3684 else
3685 begin
3686 Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
3687 // Multicast.imr_interface.S_addr := INADDR_ANY;
3688 Multicast.imr_interface.S_addr := FLocalSin.sin_addr.S_addr;
3689 SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP,
3690 PAnsiChar(@Multicast), SizeOf(Multicast)));
3691 end;
3692 ExceptCheck;
3693 end;
3694
3695 procedure TUDPBlockSocket.DropMulticast(MCastIP: string);
3696 var
3697 Multicast: TIP_mreq;
3698 Multicast6: TIPv6_mreq;
3699 n: integer;
3700 ip6: Tip6bytes;
3701 begin
3702 if FIP6Used then
3703 begin
3704 ip6 := StrToIp6(MCastIP);
3705 for n := 0 to 15 do
3706 Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
3707 Multicast6.ipv6mr_interface := 0;
3708 SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP,
3709 PAnsiChar(@Multicast6), SizeOf(Multicast6)));
3710 end
3711 else
3712 begin
3713 Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
3714 // Multicast.imr_interface.S_addr := INADDR_ANY;
3715 Multicast.imr_interface.S_addr := FLocalSin.sin_addr.S_addr;
3716 SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP,
3717 PAnsiChar(@Multicast), SizeOf(Multicast)));
3718 end;
3719 ExceptCheck;
3720 end;
3721 {$ENDIF}
3722
3723 procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer);
3724 var
3725 d: TSynaOption;
3726 begin
3727 d := TSynaOption.Create;
3728 d.Option := SOT_MulticastTTL;
3729 d.Value := TTL;
3730 DelayedOption(d);
3731 end;
3732
TUDPBlockSocket.GetMulticastTTLnull3733 function TUDPBlockSocket.GetMulticastTTL:integer;
3734 var
3735 l: Integer;
3736 begin
3737 {$IFNDEF CIL}
3738 l := SizeOf(Result);
3739 if FIP6Used then
3740 synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, @Result, l)
3741 else
3742 synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l);
3743 {$ENDIF}
3744 end;
3745
3746 procedure TUDPBlockSocket.EnableMulticastLoop(Value: Boolean);
3747 var
3748 d: TSynaOption;
3749 begin
3750 d := TSynaOption.Create;
3751 d.Option := SOT_MulticastLoop;
3752 d.Enabled := Value;
3753 DelayedOption(d);
3754 end;
3755
GetSocketTypenull3756 function TUDPBlockSocket.GetSocketType: integer;
3757 begin
3758 Result := integer(SOCK_DGRAM);
3759 end;
3760
GetSocketProtocolnull3761 function TUDPBlockSocket.GetSocketProtocol: integer;
3762 begin
3763 Result := integer(IPPROTO_UDP);
3764 end;
3765
3766 {======================================================================}
3767 constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass);
3768 begin
3769 inherited Create;
3770 FSSL := SSLPlugin.Create(self);
3771 FHTTPTunnelIP := '';
3772 FHTTPTunnelPort := '';
3773 FHTTPTunnel := False;
3774 FHTTPTunnelRemoteIP := '';
3775 FHTTPTunnelRemotePort := '';
3776 FHTTPTunnelUser := '';
3777 FHTTPTunnelPass := '';
3778 FHTTPTunnelTimeout := 30000;
3779 end;
3780
3781 constructor TTCPBlockSocket.Create;
3782 begin
3783 CreateWithSSL(SSLImplementation);
3784 end;
3785
3786 destructor TTCPBlockSocket.Destroy;
3787 begin
3788 inherited Destroy;
3789 FSSL.Free;
3790 end;
3791
TTCPBlockSocket.GetErrorDescExnull3792 function TTCPBlockSocket.GetErrorDescEx: string;
3793 begin
3794 Result := inherited GetErrorDescEx;
3795 if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then
3796 begin
3797 Result := self.SSL.LastErrorDesc;
3798 end;
3799 end;
3800
3801 procedure TTCPBlockSocket.CloseSocket;
3802 begin
3803 if FSSL.SSLEnabled then
3804 FSSL.Shutdown;
3805 if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then
3806 begin
3807 Synsock.Shutdown(FSocket, 1);
3808 Purge;
3809 end;
3810 inherited CloseSocket;
3811 end;
3812
3813 procedure TTCPBlockSocket.DoAfterConnect;
3814 begin
3815 if assigned(OnAfterConnect) then
3816 begin
3817 OnAfterConnect(Self);
3818 end;
3819 end;
3820
WaitingDatanull3821 function TTCPBlockSocket.WaitingData: Integer;
3822 begin
3823 Result := 0;
3824 if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then
3825 Result := FSSL.WaitingData;
3826 if Result = 0 then
3827 Result := inherited WaitingData;
3828 end;
3829
3830 procedure TTCPBlockSocket.Listen;
3831 var
3832 b: Boolean;
3833 Sip,SPort: string;
3834 begin
3835 if FSocksIP = '' then
3836 begin
3837 inherited Listen;
3838 end
3839 else
3840 begin
3841 Sip := GetLocalSinIP;
3842 if Sip = cAnyHost then
3843 Sip := LocalName;
3844 SPort := IntToStr(GetLocalSinPort);
3845 inherited Connect(FSocksIP, FSocksPort);
3846 b := SocksOpen;
3847 if b then
3848 b := SocksRequest(2, Sip, SPort);
3849 if b then
3850 b := SocksResponse;
3851 if not b and (FLastError = 0) then
3852 FLastError := WSANO_RECOVERY;
3853 FSocksLocalIP := FSocksResponseIP;
3854 if FSocksLocalIP = cAnyHost then
3855 FSocksLocalIP := FSocksIP;
3856 FSocksLocalPort := FSocksResponsePort;
3857 FSocksRemoteIP := '';
3858 FSocksRemotePort := '';
3859 ExceptCheck;
3860 DoStatus(HR_Listen, '');
3861 end;
3862 end;
3863
Acceptnull3864 function TTCPBlockSocket.Accept: TSocket;
3865 begin
3866 if FUsingSocks then
3867 begin
3868 if not SocksResponse and (FLastError = 0) then
3869 FLastError := WSANO_RECOVERY;
3870 FSocksRemoteIP := FSocksResponseIP;
3871 FSocksRemotePort := FSocksResponsePort;
3872 Result := FSocket;
3873 ExceptCheck;
3874 DoStatus(HR_Accept, '');
3875 end
3876 else
3877 begin
3878 result := inherited Accept;
3879 end;
3880 end;
3881
3882 procedure TTCPBlockSocket.Connect(IP, Port: string);
3883 begin
3884 if FSocksIP <> '' then
3885 SocksDoConnect(IP, Port)
3886 else
3887 if FHTTPTunnelIP <> '' then
3888 HTTPTunnelDoConnect(IP, Port)
3889 else
3890 inherited Connect(IP, Port);
3891 if FLasterror = 0 then
3892 DoAfterConnect;
3893 end;
3894
3895 procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string);
3896 var
3897 b: Boolean;
3898 begin
3899 inherited Connect(FSocksIP, FSocksPort);
3900 if FLastError = 0 then
3901 begin
3902 b := SocksOpen;
3903 if b then
3904 b := SocksRequest(1, IP, Port);
3905 if b then
3906 b := SocksResponse;
3907 if not b and (FLastError = 0) then
3908 FLastError := WSASYSNOTREADY;
3909 FSocksLocalIP := FSocksResponseIP;
3910 FSocksLocalPort := FSocksResponsePort;
3911 FSocksRemoteIP := IP;
3912 FSocksRemotePort := Port;
3913 end;
3914 ExceptCheck;
3915 DoStatus(HR_Connect, IP + ':' + Port);
3916 end;
3917
3918 procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string);
3919 //bugfixed by Mike Green (mgreen@emixode.com)
3920 var
3921 s: string;
3922 begin
3923 Port := IntToStr(ResolvePort(Port));
3924 inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort);
3925 if FLastError <> 0 then
3926 Exit;
3927 FHTTPTunnel := False;
3928 if IsIP6(IP) then
3929 IP := '[' + IP + ']';
3930 SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF);
3931 if FHTTPTunnelUser <> '' then
3932 Sendstring('Proxy-Authorization: Basic ' +
3933 EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF);
3934 SendString(CRLF);
3935 repeat
3936 s := RecvTerminated(FHTTPTunnelTimeout, #$0a);
3937 if FLastError <> 0 then
3938 Break;
3939 if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then
3940 FHTTPTunnel := s[10] = '2';
3941 until (s = '') or (s = #$0d);
3942 if (FLasterror = 0) and not FHTTPTunnel then
3943 FLastError := WSAECONNREFUSED;
3944 FHTTPTunnelRemoteIP := IP;
3945 FHTTPTunnelRemotePort := Port;
3946 ExceptCheck;
3947 end;
3948
3949 procedure TTCPBlockSocket.SSLDoConnect;
3950 begin
3951 ResetLastError;
3952 if not FSSL.Connect then
3953 FLastError := WSASYSNOTREADY;
3954 ExceptCheck;
3955 end;
3956
3957 procedure TTCPBlockSocket.SSLDoShutdown;
3958 begin
3959 ResetLastError;
3960 FSSL.BiShutdown;
3961 end;
3962
TTCPBlockSocket.GetLocalSinIPnull3963 function TTCPBlockSocket.GetLocalSinIP: string;
3964 begin
3965 if FUsingSocks then
3966 Result := FSocksLocalIP
3967 else
3968 Result := inherited GetLocalSinIP;
3969 end;
3970
GetRemoteSinIPnull3971 function TTCPBlockSocket.GetRemoteSinIP: string;
3972 begin
3973 if FUsingSocks then
3974 Result := FSocksRemoteIP
3975 else
3976 if FHTTPTunnel then
3977 Result := FHTTPTunnelRemoteIP
3978 else
3979 Result := inherited GetRemoteSinIP;
3980 end;
3981
TTCPBlockSocket.GetLocalSinPortnull3982 function TTCPBlockSocket.GetLocalSinPort: Integer;
3983 begin
3984 if FUsingSocks then
3985 Result := StrToIntDef(FSocksLocalPort, 0)
3986 else
3987 Result := inherited GetLocalSinPort;
3988 end;
3989
GetRemoteSinPortnull3990 function TTCPBlockSocket.GetRemoteSinPort: Integer;
3991 begin
3992 if FUsingSocks then
3993 Result := ResolvePort(FSocksRemotePort)
3994 else
3995 if FHTTPTunnel then
3996 Result := StrToIntDef(FHTTPTunnelRemotePort, 0)
3997 else
3998 Result := inherited GetRemoteSinPort;
3999 end;
4000
RecvBuffernull4001 function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
4002 begin
4003 if FSSL.SSLEnabled then
4004 begin
4005 Result := 0;
4006 if TestStopFlag then
4007 Exit;
4008 ResetLastError;
4009 LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv);
4010 Result := FSSL.RecvBuffer(Buffer, Len);
4011 if FSSL.LastError <> 0 then
4012 FLastError := WSASYSNOTREADY;
4013 ExceptCheck;
4014 Inc(FRecvCounter, Result);
4015 DoStatus(HR_ReadCount, IntToStr(Result));
4016 DoMonitor(False, Buffer, Result);
4017 DoReadFilter(Buffer, Result);
4018 end
4019 else
4020 Result := inherited RecvBuffer(Buffer, Len);
4021 end;
4022
TTCPBlockSocket.SendBuffernull4023 function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
4024 var
4025 x, y: integer;
4026 l, r: integer;
4027 {$IFNDEF CIL}
4028 p: Pointer;
4029 {$ENDIF}
4030 begin
4031 if FSSL.SSLEnabled then
4032 begin
4033 Result := 0;
4034 if TestStopFlag then
4035 Exit;
4036 ResetLastError;
4037 DoMonitor(True, Buffer, Length);
4038 {$IFDEF CIL}
4039 Result := FSSL.SendBuffer(Buffer, Length);
4040 if FSSL.LastError <> 0 then
4041 FLastError := WSASYSNOTREADY;
4042 Inc(FSendCounter, Result);
4043 DoStatus(HR_WriteCount, IntToStr(Result));
4044 {$ELSE}
4045 l := Length;
4046 x := 0;
4047 while x < l do
4048 begin
4049 y := l - x;
4050 if y > FSendMaxChunk then
4051 y := FSendMaxChunk;
4052 if y > 0 then
4053 begin
4054 LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
4055 p := IncPoint(Buffer, x);
4056 r := FSSL.SendBuffer(p, y);
4057 if FSSL.LastError <> 0 then
4058 FLastError := WSASYSNOTREADY;
4059 if Flasterror <> 0 then
4060 Break;
4061 Inc(x, r);
4062 Inc(Result, r);
4063 Inc(FSendCounter, r);
4064 DoStatus(HR_WriteCount, IntToStr(r));
4065 end
4066 else
4067 break;
4068 end;
4069 {$ENDIF}
4070 ExceptCheck;
4071 end
4072 else
4073 Result := inherited SendBuffer(Buffer, Length);
4074 end;
4075
SSLAcceptConnectionnull4076 function TTCPBlockSocket.SSLAcceptConnection: Boolean;
4077 begin
4078 ResetLastError;
4079 if not FSSL.Accept then
4080 FLastError := WSASYSNOTREADY;
4081 ExceptCheck;
4082 Result := FLastError = 0;
4083 end;
4084
TTCPBlockSocket.GetSocketTypenull4085 function TTCPBlockSocket.GetSocketType: integer;
4086 begin
4087 Result := integer(SOCK_STREAM);
4088 end;
4089
GetSocketProtocolnull4090 function TTCPBlockSocket.GetSocketProtocol: integer;
4091 begin
4092 Result := integer(IPPROTO_TCP);
4093 end;
4094
4095 {======================================================================}
4096
TICMPBlockSocket.GetSocketTypenull4097 function TICMPBlockSocket.GetSocketType: integer;
4098 begin
4099 Result := integer(SOCK_RAW);
4100 end;
4101
GetSocketProtocolnull4102 function TICMPBlockSocket.GetSocketProtocol: integer;
4103 begin
4104 if FIP6Used then
4105 Result := integer(IPPROTO_ICMPV6)
4106 else
4107 Result := integer(IPPROTO_ICMP);
4108 end;
4109
4110 {======================================================================}
4111
TRAWBlockSocket.GetSocketTypenull4112 function TRAWBlockSocket.GetSocketType: integer;
4113 begin
4114 Result := integer(SOCK_RAW);
4115 end;
4116
GetSocketProtocolnull4117 function TRAWBlockSocket.GetSocketProtocol: integer;
4118 begin
4119 Result := integer(IPPROTO_RAW);
4120 end;
4121
4122 {======================================================================}
4123
TPGMmessageBlockSocket.GetSocketTypenull4124 function TPGMmessageBlockSocket.GetSocketType: integer;
4125 begin
4126 Result := integer(SOCK_RDM);
4127 end;
4128
GetSocketProtocolnull4129 function TPGMmessageBlockSocket.GetSocketProtocol: integer;
4130 begin
4131 Result := integer(IPPROTO_RM);
4132 end;
4133
4134 {======================================================================}
4135
TPGMstreamBlockSocket.GetSocketTypenull4136 function TPGMstreamBlockSocket.GetSocketType: integer;
4137 begin
4138 Result := integer(SOCK_STREAM);
4139 end;
4140
GetSocketProtocolnull4141 function TPGMstreamBlockSocket.GetSocketProtocol: integer;
4142 begin
4143 Result := integer(IPPROTO_RM);
4144 end;
4145
4146 {======================================================================}
4147
4148 constructor TSynaClient.Create;
4149 begin
4150 inherited Create;
4151 FIPInterface := cAnyHost;
4152 FTargetHost := cLocalhost;
4153 FTargetPort := cAnyPort;
4154 FTimeout := 5000;
4155 FUsername := '';
4156 FPassword := '';
4157 end;
4158
4159 {======================================================================}
4160
4161 constructor TCustomSSL.Create(const Value: TTCPBlockSocket);
4162 begin
4163 inherited Create;
4164 FSocket := Value;
4165 FSSLEnabled := False;
4166 FUsername := '';
4167 FPassword := '';
4168 FLastError := 0;
4169 FLastErrorDesc := '';
4170 FVerifyCert := False;
4171 FSSLType := LT_all;
4172 FKeyPassword := '';
4173 FCiphers := '';
4174 FCertificateFile := '';
4175 FPrivateKeyFile := '';
4176 FCertCAFile := '';
4177 FCertCA := '';
4178 FTrustCertificate := '';
4179 FTrustCertificateFile := '';
4180 FCertificate := '';
4181 FPrivateKey := '';
4182 FPFX := '';
4183 FPFXfile := '';
4184 FSSHChannelType := '';
4185 FSSHChannelArg1 := '';
4186 FSSHChannelArg2 := '';
4187 FCertComplianceLevel := -1; //default
4188 FSNIHost := '';
4189 end;
4190
4191 procedure TCustomSSL.Assign(const Value: TCustomSSL);
4192 begin
4193 FUsername := Value.Username;
4194 FPassword := Value.Password;
4195 FVerifyCert := Value.VerifyCert;
4196 FSSLType := Value.SSLType;
4197 FKeyPassword := Value.KeyPassword;
4198 FCiphers := Value.Ciphers;
4199 FCertificateFile := Value.CertificateFile;
4200 FPrivateKeyFile := Value.PrivateKeyFile;
4201 FCertCAFile := Value.CertCAFile;
4202 FCertCA := Value.CertCA;
4203 FTrustCertificate := Value.TrustCertificate;
4204 FTrustCertificateFile := Value.TrustCertificateFile;
4205 FCertificate := Value.Certificate;
4206 FPrivateKey := Value.PrivateKey;
4207 FPFX := Value.PFX;
4208 FPFXfile := Value.PFXfile;
4209 FCertComplianceLevel := Value.CertComplianceLevel;
4210 FSNIHost := Value.FSNIHost;
4211 end;
4212
4213 procedure TCustomSSL.ReturnError;
4214 begin
4215 FLastError := -1;
4216 FLastErrorDesc := 'SSL/TLS support is not compiled!';
4217 end;
4218
TCustomSSL.LibVersionnull4219 function TCustomSSL.LibVersion: String;
4220 begin
4221 Result := '';
4222 end;
4223
LibNamenull4224 function TCustomSSL.LibName: String;
4225 begin
4226 Result := '';
4227 end;
4228
CreateSelfSignedCertnull4229 function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean;
4230 begin
4231 Result := False;
4232 end;
4233
Connectnull4234 function TCustomSSL.Connect: boolean;
4235 begin
4236 ReturnError;
4237 Result := False;
4238 end;
4239
TCustomSSL.Acceptnull4240 function TCustomSSL.Accept: boolean;
4241 begin
4242 ReturnError;
4243 Result := False;
4244 end;
4245
Shutdownnull4246 function TCustomSSL.Shutdown: boolean;
4247 begin
4248 ReturnError;
4249 Result := False;
4250 end;
4251
TCustomSSL.BiShutdownnull4252 function TCustomSSL.BiShutdown: boolean;
4253 begin
4254 ReturnError;
4255 Result := False;
4256 end;
4257
SendBuffernull4258 function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
4259 begin
4260 ReturnError;
4261 Result := integer(SOCKET_ERROR);
4262 end;
4263
4264 procedure TCustomSSL.SetCertCAFile(const Value: string);
4265 begin
4266 FCertCAFile := Value;
4267 end;
4268
TCustomSSL.RecvBuffernull4269 function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
4270 begin
4271 ReturnError;
4272 Result := integer(SOCKET_ERROR);
4273 end;
4274
WaitingDatanull4275 function TCustomSSL.WaitingData: Integer;
4276 begin
4277 ReturnError;
4278 Result := 0;
4279 end;
4280
GetSSLVersionnull4281 function TCustomSSL.GetSSLVersion: string;
4282 begin
4283 Result := '';
4284 end;
4285
TCustomSSL.GetPeerSubjectnull4286 function TCustomSSL.GetPeerSubject: string;
4287 begin
4288 Result := '';
4289 end;
4290
GetPeerSerialNonull4291 function TCustomSSL.GetPeerSerialNo: integer;
4292 begin
4293 Result := -1;
4294 end;
4295
GetPeerNamenull4296 function TCustomSSL.GetPeerName: string;
4297 begin
4298 Result := '';
4299 end;
4300
GetPeerNameHashnull4301 function TCustomSSL.GetPeerNameHash: cardinal;
4302 begin
4303 Result := 0;
4304 end;
4305
TCustomSSL.GetPeerIssuernull4306 function TCustomSSL.GetPeerIssuer: string;
4307 begin
4308 Result := '';
4309 end;
4310
GetPeerFingerprintnull4311 function TCustomSSL.GetPeerFingerprint: string;
4312 begin
4313 Result := '';
4314 end;
4315
TCustomSSL.GetCertInfonull4316 function TCustomSSL.GetCertInfo: string;
4317 begin
4318 Result := '';
4319 end;
4320
GetCipherNamenull4321 function TCustomSSL.GetCipherName: string;
4322 begin
4323 Result := '';
4324 end;
4325
GetCipherBitsnull4326 function TCustomSSL.GetCipherBits: integer;
4327 begin
4328 Result := 0;
4329 end;
4330
GetCipherAlgBitsnull4331 function TCustomSSL.GetCipherAlgBits: integer;
4332 begin
4333 Result := 0;
4334 end;
4335
GetVerifyCertnull4336 function TCustomSSL.GetVerifyCert: integer;
4337 begin
4338 Result := 1;
4339 end;
4340
TCustomSSL.DoVerifyCertnull4341 function TCustomSSL.DoVerifyCert:boolean;
4342 begin
4343 if assigned(OnVerifyCert) then
4344 begin
4345 result:=OnVerifyCert(Self);
4346 end
4347 else
4348 result:=true;
4349 end;
4350
4351
4352 {======================================================================}
4353
TSSLNone.LibVersionnull4354 function TSSLNone.LibVersion: String;
4355 begin
4356 Result := 'Without SSL support';
4357 end;
4358
LibNamenull4359 function TSSLNone.LibName: String;
4360 begin
4361 Result := 'ssl_none';
4362 end;
4363
4364 {======================================================================}
4365
4366 initialization
4367 begin
4368 {$IFDEF ONCEWINSOCK}
4369 if not InitSocketInterface(DLLStackName) then
4370 begin
4371 e := ESynapseError.Create('Error loading Socket interface (' + DLLStackName + ')!');
4372 e.ErrorCode := 0;
4373 e.ErrorMessage := 'Error loading Socket interface (' + DLLStackName + ')!';
4374 raise e;
4375 end;
4376 synsock.WSAStartup(WinsockLevel, WsaDataOnce);
4377 {$ENDIF}
4378 end;
4379
4380 finalization
4381 begin
4382 {$IFDEF ONCEWINSOCK}
4383 synsock.WSACleanup;
4384 DestroySocketInterface;
4385 {$ENDIF}
4386 end;
4387
4388 end.
4389