2 Basic object-oriented network functions
3 Copyright (C) 2010-2018 MegaBrutal
5 This unit is free software: you can redistribute it and/or modify
6 it under the terms of the GNU Lesser General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
10 This unit is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU Lesser General Public License for more details.
15 You should have received a copy of the GNU Lesser General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
21 This unit provides an object-oriented interface to manage TCP/IPv4
24 TTCPConnection - provides methods for sending/receiving buffers through
25 the connection, and some support for text-based communication.
27 TTCPRFCConnection - in addition to TTCPConnection, it provides methods
28 to send/receive RFC-style commands and responses.
30 TTCPListener - opens a port to listen on, and accepts incoming connections
31 through it. Override its "HandleClient" method to serve connected
40 uses Classes
, Sockets
, SocketUtils
, DNSResolve
, NetRFC
, Common
;
45 { These are here so users of this unit don't necessarily have to
46 use Sockets as well. }
47 AF_UNSPEC
= Sockets
.AF_UNSPEC
;
48 AF_INET
= Sockets
.AF_INET
;
49 AF_INET6
= Sockets
.AF_INET6
;
51 { Connection feature requests: }
53 NET_TCP_RFCSUPPORT
= 1;
55 { Default socket timeout: }
56 DEF_SOCK_TIMEOUT
= 5 * 60000; { 5 minutes. }
61 TTCPConnection
= class
62 constructor Create
; overload
;
63 constructor Create(const HostName
: string; Port
: word); overload
;
64 constructor Create(Socket
: socket
; const Addr
: TSockAddr6
); overload
;
65 destructor Destroy
; override;
73 function Connect(const HostName
: string; Port
: word): boolean;
75 procedure ReverseDNSLookup
;
76 function VerifyFCrDNS
: boolean;
77 procedure SetSockTimeOut(TimeOut
: DWord
);
78 function ReadBuffer(PtrBuffer
: pointer; Len
: size_t
): ssize_t
;
79 function WriteBuffer(PtrBuffer
: pointer; Len
: size_t
): ssize_t
;
80 function ReadLn(var Line
: string): boolean;
81 function WriteLn(const Line
: string): boolean;
82 property Connected
: boolean read FConnected
;
83 property Socket
: socket read FSocket
;
84 property HostIP
: TIPNamePair read FHostIP
;
85 property SockTimeOut
: DWord read FSockTimeOut write SetSockTimeOut
;
88 TTCPRFCConnection
= class(TTCPConnection
)
90 function ReadCommand(var Command
: shortstring
; var Prms
: string): boolean;
91 function ReadResponse(Response
: TRFCReply
): boolean;
92 function SendCommand(Command
: shortstring
): boolean; overload
;
93 function SendCommand(Command
: shortstring
; Prms
: string): boolean; overload
;
94 function SendResponse(Response
: TRFCReply
): boolean;
98 TTCPAcceptHandler
= procedure(Connection
: TTCPConnection
) of object;
100 TTCPAcceptor
= class(TThread
)
101 constructor Create(Handler
: TTCPAcceptHandler
; TCPConnection
: TTCPConnection
);
103 FHandler
: TTCPAcceptHandler
;
104 FTCPConnection
: TTCPConnection
;
105 procedure Execute
; override;
108 TTCPListener
= class(TThread
)
109 constructor Create(const Address
: string; Port
: word; Family
: word; FeatureRequest
: word);
110 {destructor Destroy; override;}
112 FFeatureRequest
: word;
114 FListenAddress
: string;
116 FListenSocket
: socket
;
117 SockAddr
: TSockAddr6
;
119 procedure HandleClient(Connection
: TTCPConnection
); virtual; abstract;
120 procedure Execute
; override;
122 property ListenPort
: word read FListenPort
;
123 function StartListen
: boolean;
124 procedure StopListen
;
132 constructor TTCPConnection
.Create
;
133 { Create an instance, but don't connect to anywhere yet. }
138 FSockTimeOut
:= DEF_SOCK_TIMEOUT
;
141 constructor TTCPConnection
.Create(const HostName
: string; Port
: word);
142 { Connect to the given port on the given hostname. }
145 Connect(HostName
, Port
);
148 constructor TTCPConnection
.Create(Socket
: socket
; const Addr
: TSockAddr6
);
149 { Use an already connected socket. }
154 FHostIP
:= TIPNamePair
.Create('', IPToStr(@Addr
));
158 destructor TTCPConnection
.Destroy
;
160 if FConnected
then Disconnect
;
165 constructor TTCPAcceptor
.Create(Handler
: TTCPAcceptHandler
; TCPConnection
: TTCPConnection
);
166 { Start a connection handler on a distinct thread. }
169 FTCPConnection
:= TCPConnection
;
170 FreeOnTerminate
:= true;
171 inherited Create(false);
175 constructor TTCPListener
.Create(const Address
: string; Port
: word; Family
: word; FeatureRequest
: word);
178 FListenAddress
:= Address
;
180 FFeatureRequest
:= FeatureRequest
;
181 FreeOnTerminate
:= false;
182 FillChar(SockAddr
, SizeOf(SockAddr
), 0);
183 inherited Create(true);
187 function TTCPConnection
.Connect(const HostName
: string; Port
: word): boolean;
188 { Resolves the given hostname, and tries to connect it on the given port. }
189 var GAIResult
: TGAIResult
;
191 GAIResult
:= ResolveHost(HostName
, AF_UNSPEC
);
192 if GAIResult
.GAIError
= 0 then begin
193 Move(GAIResult
.AddrInfo
^.ai_addr
^, SockAddr
, GAIResult
.AddrInfo
^.ai_addrlen
);
194 SockAddr
.sin6_port
:= htons(Port
);
197 FSocket
:= fpSocket(GAIResult
.AddrInfo
^.ai_family
, SOCK_STREAM
, 0);
199 if (FSocket
<> -1) then begin
201 { Try to initiate connection. }
202 FConnected
:= fpConnect(FSocket
, @SockAddr
, GAIResult
.AddrInfo
^.ai_addrlen
) <> -1;
204 if FConnected
then begin
205 FHostIP
:= TIPNamePair
.Create(HostName
, IPToStr(@SockAddr
));
206 SetSockTimeOut(FSockTimeOut
);
209 CloseSocket(FSocket
);
218 procedure TTCPConnection
.Disconnect
;
220 fpShutdown(FSocket
, 2);
221 CloseSocket(FSocket
);
227 procedure TTCPConnection
.ReverseDNSLookup
;
228 { Performs a reverse DNS lookup, and updates the HostIP structure. }
229 var NHostIP
: TIPNamePair
;
231 if FConnected
then begin
232 NHostIP
:= TIPNamePair
.Create(ResolveIP(PSockAddr(@SockAddr
)), FHostIP
.IP
);
238 function TTCPConnection
.VerifyFCrDNS
: boolean;
239 var GAIResult
: TGAIResult
; ai
: PAddrInfo
;
242 GAIResult
:= ResolveHost(HostIP
.Name
, AF_UNSPEC
);
243 if GAIResult
.GAIError
= 0 then begin
244 ai
:= GAIResult
.AddrInfo
;
245 { One of the addresses must match. }
246 while (ai
<> nil) and not Result
do begin
247 Result
:= IPToStr(ai
^.ai_addr
) = HostIP
.IP
;
253 procedure TTCPConnection
.SetSockTimeOut(TimeOut
: DWord
);
255 FSockTimeOut
:= TimeOut
;
256 if Connected
then begin
257 fpSetSockOpt(FSocket
, SOL_SOCKET
, SO_RCVTIMEO
, @FSockTimeOut
, SizeOf(FSockTimeOut
));
258 fpSetSockOpt(FSocket
, SOL_SOCKET
, SO_SNDTIMEO
, @FSockTimeOut
, SizeOf(FSockTimeOut
));
262 function TTCPConnection
.ReadBuffer(PtrBuffer
: pointer; Len
: size_t
): ssize_t
;
264 Result
:= fpRecv(FSocket
, PtrBuffer
, Len
, 0);
267 function TTCPConnection
.WriteBuffer(PtrBuffer
: pointer; Len
: size_t
): ssize_t
;
269 Result
:= fpSend(FSocket
, PtrBuffer
, Len
, 0);
272 function TTCPConnection
.ReadLn(var Line
: string): boolean;
274 Result
:= SockReadLn(FSocket
, Line
);
277 function TTCPConnection
.WriteLn(const Line
: string): boolean;
279 Result
:= SockWriteLn(FSocket
, Line
);
283 function TTCPRFCConnection
.ReadCommand(var Command
: shortstring
; var Prms
: string): boolean;
285 Result
:= NetRFC
.ReadCommand(FSocket
, Command
, Prms
);
288 function TTCPRFCConnection
.ReadResponse(Response
: TRFCReply
): boolean;
290 Result
:= NetRFC
.ReadResponse(FSocket
, Response
);
293 function TTCPRFCConnection
.SendCommand(Command
: shortstring
): boolean;
295 Result
:= NetRFC
.SendCommand(FSocket
, Command
);
298 function TTCPRFCConnection
.SendCommand(Command
: shortstring
; Prms
: string): boolean;
300 Result
:= NetRFC
.SendCommand(FSocket
, Command
, Prms
);
303 function TTCPRFCConnection
.SendResponse(Response
: TRFCReply
): boolean;
305 Result
:= NetRFC
.SendResponse(FSocket
, Response
);
309 procedure TTCPAcceptor
.Execute
;
311 FHandler(FTCPConnection
);
315 function TTCPListener
.StartListen
: boolean;
316 var GAIResult
: TGAIResult
;
318 FListenSocket
:= fpSocket(FFamily
, SOCK_STREAM
, 0);
319 if FListenSocket
<> -1 then begin
320 GAIResult
:= ResolveHost(FListenAddress
, FFamily
);
321 if GAIResult
.GAIError
= 0 then begin
322 Move(GAIResult
.AddrInfo
^.ai_addr
^, SockAddr
, GAIResult
.AddrInfo
^.ai_addrlen
);
323 SockAddr
.sin6_port
:= htons(FListenPort
);
325 if fpBind(FListenSocket
, @SockAddr
, GAIResult
.AddrInfo
^.ai_addrlen
) <> -1 then begin
326 { It seems the maximum connection value isn't enforced by the
327 Free Pascal library, so this 512 is a constant, dummy value. }
328 if fpListen(FListenSocket
, 512) <> -1 then begin
343 procedure TTCPListener
.StopListen
;
349 procedure TTCPListener
.Execute
;
350 var ClientSocket
: socket
; AcceptFailCount
: word; Len
: longint;
351 TCPConnection
: TTCPConnection
;
353 { Now, accept connections. }
355 while not Terminated
do begin
356 Len
:= SizeOf(SockAddr
);
357 ClientSocket
:= fpAccept(FListenSocket
, @SockAddr
, @Len
);
358 if ClientSocket
<> -1 then begin
361 { Creates the requested TTCPConnection object for the accepted
363 case FFeatureRequest
of
365 TCPConnection
:= TTCPConnection
.Create(ClientSocket
, SockAddr
);
367 TCPConnection
:= TTCPRFCConnection
.Create(ClientSocket
, SockAddr
);
370 { Then start a new thread with the connection handler. }
371 TTCPAcceptor
.Create(HandleClient
, TCPConnection
);
374 Inc(AcceptFailCount
);
375 if AcceptFailCount
>= 512 then Terminate
;