source: trunk/Packages/synapse/source/lib/blcksock.pas

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