Network.pas

   1 {
   2    Basic object-oriented network functions
   3    Copyright (C) 2010-2018 MegaBrutal
   4
   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.
   9
  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.
  14
  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/>.
  17 }
  18
  19 {
  20    Unit: Network
  21    This unit provides an object-oriented interface to manage TCP/IPv4
  22    connections.
  23
  24    TTCPConnection - provides methods for sending/receiving buffers through
  25       the connection, and some support for text-based communication.
  26
  27    TTCPRFCConnection - in addition to TTCPConnection, it provides methods
  28       to send/receive RFC-style commands and responses.
  29
  30    TTCPListener - opens a port to listen on, and accepts incoming connections
  31       through it. Override its "HandleClient" method to serve connected
  32       clients.
  33 }
  34
  35
  36 {$MODE DELPHI}
  37 unit Network;
  38
  39 interface
  40 uses Classes, Sockets, SocketUtils, ctypes, DNSResolve, NetRFC, Common;
  41
  42 const
  43
  44    { Address families: }
  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;
  50
  51    { Connection feature requests: }
  52    NET_TCP_BASIC        =  0;
  53    NET_TCP_RFCSUPPORT   =  1;
  54
  55    { Default socket timeout: }
  56    DEF_SOCK_TIMEOUT     =  5 * 60000;     { 5 minutes. }
  57
  58
  59 type
  60
  61    TTCPConnection = class
  62       constructor Create; overload;
  63       constructor Create(const HostName: string; Port: word); overload;
  64       constructor Create(Socket: socket); overload;
  65       destructor Destroy; override;
  66    private
  67       FConnected: boolean;
  68       FSocket: socket;
  69       FHostIP: TIPNamePair;
  70       FSockTimeOut: DWord;
  71       SrcSockAddr: TSockAddr;
  72       SrcSockAddr6: TSockAddr6;
  73       DstSockAddr: TSockAddr6;
  74    protected
  75       function IsNullAddress(SockAddr: PSockAddr): boolean;
  76       function BindSrcAddr(Socket: socket; Family: word): cint;
  77    public
  78       function SetBindAddress(Family: word; const HostName: string): boolean;
  79       function Connect(const HostName: string; Port: word): boolean;
  80       procedure Disconnect;
  81       procedure ReverseDNSLookup;
  82       function VerifyFCrDNS: boolean;
  83       procedure SetSockTimeOut(TimeOut: DWord);
  84       function ReadBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
  85       function WriteBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
  86       function ReadLn(var Line: string): boolean;
  87       function WriteLn(const Line: string): boolean;
  88       property Connected: boolean read FConnected;
  89       property Socket: socket read FSocket;
  90       property HostIP: TIPNamePair read FHostIP;
  91       property SockTimeOut: DWord read FSockTimeOut write SetSockTimeOut;
  92    end;
  93
  94    TTCPRFCConnection = class(TTCPConnection)
  95    public
  96       function ReadCommand(var Command: shortstring; var Prms: string): boolean;
  97       function ReadResponse(Response: TRFCReply): boolean;
  98       function SendCommand(Command: shortstring): boolean; overload;
  99       function SendCommand(Command: shortstring; Prms: string): boolean; overload;
 100       function SendResponse(Response: TRFCReply): boolean;
 101    end;
 102
 103
 104    TTCPAcceptHandler = procedure(Connection: TTCPConnection) of object;
 105
 106    TTCPAcceptor = class(TThread)
 107       constructor Create(Handler: TTCPAcceptHandler; TCPConnection: TTCPConnection);
 108    protected
 109       FHandler: TTCPAcceptHandler;
 110       FTCPConnection: TTCPConnection;
 111       procedure Execute; override;
 112    end;
 113
 114    TTCPListener = class(TThread)
 115       constructor Create(const Address: string; Port: word; Family: word; FeatureRequest: word);
 116       {destructor Destroy; override;}
 117    private
 118       FFeatureRequest: word;
 119       FFamily: word;
 120       FListenAddress: string;
 121       FListenPort: word;
 122       FListenSocket: socket;
 123       SockAddr: TSockAddr6;
 124    protected
 125       procedure HandleClient(Connection: TTCPConnection); virtual; abstract;
 126       procedure Execute; override;
 127    public
 128       property ListenPort: word read FListenPort;
 129       function StartListen: boolean;
 130       procedure StopListen;
 131    end;
 132
 133
 134
 135 implementation
 136
 137
 138 constructor TTCPConnection.Create;
 139 { Create an instance, but don't connect to anywhere yet. }
 140 begin
 141    inherited Create;
 142    FConnected:= false;
 143    FSocket:= -1;
 144    FSockTimeOut:= DEF_SOCK_TIMEOUT;
 145    FillChar(SrcSockAddr, SizeOf(SrcSockAddr), 0);
 146    FillChar(SrcSockAddr6, SizeOf(SrcSockAddr6), 0);
 147    FillChar(DstSockAddr, SizeOf(DstSockAddr), 0);
 148    SrcSockAddr.sin_family:= AF_INET;
 149    SrcSockAddr6.sin6_family:= AF_INET6;
 150 end;
 151
 152 constructor TTCPConnection.Create(const HostName: string; Port: word);
 153 { Connect to the given port on the given hostname. }
 154 begin
 155    Create;
 156    Connect(HostName, Port);
 157 end;
 158
 159 constructor TTCPConnection.Create(Socket: socket);
 160 { Use an already connected socket. }
 161 var ssocklen, dsocklen: TSockLen;
 162 begin
 163    inherited Create;
 164    FSocket:= Socket;
 165    ssocklen:= SizeOf(SrcSockAddr);
 166    dsocklen:= SizeOf(DstSockAddr);
 167    fpgetsockname(FSocket, @SrcSockAddr, @ssocklen);
 168    fpgetpeername(FSocket, @DstSockAddr, @dsocklen);
 169    FHostIP:= TIPNamePair.Create('', IPToStr(@DstSockAddr));
 170    FConnected:= true;
 171 end;
 172
 173 destructor TTCPConnection.Destroy;
 174 begin
 175    if FConnected then Disconnect;
 176    inherited Destroy;
 177 end;
 178
 179
 180 constructor TTCPAcceptor.Create(Handler: TTCPAcceptHandler; TCPConnection: TTCPConnection);
 181 { Start a connection handler on a distinct thread. }
 182 begin
 183    FHandler:= Handler;
 184    FTCPConnection:= TCPConnection;
 185    FreeOnTerminate:= true;
 186    inherited Create(false);
 187 end;
 188
 189
 190 constructor TTCPListener.Create(const Address: string; Port: word; Family: word; FeatureRequest: word);
 191 begin
 192    FFamily:= Family;
 193    FListenAddress:= Address;
 194    FListenPort:= Port;
 195    FFeatureRequest:= FeatureRequest;
 196    FreeOnTerminate:= false;
 197    FillChar(SockAddr, SizeOf(SockAddr), 0);
 198    inherited Create(true);
 199 end;
 200
 201
 202 function TTCPConnection.IsNullAddress(SockAddr: PSockAddr): boolean;
 203 begin
 204    if SockAddr^.sin_family = AF_INET then
 205       Result:= SockAddr^.sin_addr.s_addr = 0
 206    else if SockAddr^.sin_family = AF_INET6 then
 207       Result:= (PSockAddr6(SockAddr)^.sin6_addr.u6_addr32[0] = 0)
 208          and (PSockAddr6(SockAddr)^.sin6_addr.u6_addr32[1] = 0)
 209          and (PSockAddr6(SockAddr)^.sin6_addr.u6_addr32[2] = 0)
 210          and (PSockAddr6(SockAddr)^.sin6_addr.u6_addr32[3] = 0)
 211    else
 212       Result:= true;
 213 end;
 214
 215 function TTCPConnection.BindSrcAddr(Socket: socket; Family: word): cint;
 216 var SockAddr: PSockAddr; addrlen: size_t;
 217 begin
 218    case Family of
 219       AF_INET:
 220          begin
 221             SockAddr:= @SrcSockAddr;
 222             addrlen:= SizeOf(SrcSockAddr);
 223          end;
 224       AF_INET6:
 225          begin
 226             SockAddr:= @SrcSockAddr6;
 227             addrlen:= SizeOf(SrcSockAddr6);
 228          end;
 229    end;
 230
 231    if not IsNullAddress(SockAddr) then
 232       Result:= fpBind(Socket, SockAddr, addrlen)
 233    else
 234       Result:= 0;
 235 end;
 236
 237 function TTCPConnection.SetBindAddress(Family: word; const HostName: string): boolean;
 238 var GAIResult: TGAIResult; SockAddr: PSockAddr;
 239 begin
 240    GAIResult:= ResolveHost(HostName, Family);
 241    if GAIResult.GAIError = 0 then begin
 242       case GAIResult.AddrInfo^.ai_family of
 243          AF_INET:    SockAddr:= @SrcSockAddr;
 244          AF_INET6:   SockAddr:= @SrcSockAddr6;
 245       end;
 246       Move(GAIResult.AddrInfo^.ai_addr^, SockAddr^, GAIResult.AddrInfo^.ai_addrlen);
 247       FreeHost(GAIResult);
 248       Result:= true;
 249    end
 250    else
 251       Result:= false;
 252 end;
 253
 254 function TTCPConnection.Connect(const HostName: string; Port: word): boolean;
 255 { Resolves the given hostname, and tries to connect it on the given port. }
 256 var GAIResult: TGAIResult;
 257 begin
 258    GAIResult:= ResolveHost(HostName, AF_UNSPEC);
 259    if GAIResult.GAIError = 0 then begin
 260       Move(GAIResult.AddrInfo^.ai_addr^, DstSockAddr, GAIResult.AddrInfo^.ai_addrlen);
 261       DstSockAddr.sin6_port:= htons(Port);
 262
 263       { Create socket. }
 264       FSocket:= fpSocket(GAIResult.AddrInfo^.ai_family, SOCK_STREAM, 0);
 265
 266       if (FSocket <> -1) then begin
 267
 268          if BindSrcAddr(FSocket, GAIResult.AddrInfo^.ai_family) = 0 then begin
 269
 270             { Try to initiate connection. }
 271             FConnected:= fpConnect(FSocket, @DstSockAddr, GAIResult.AddrInfo^.ai_addrlen) <> -1;
 272
 273             if FConnected then begin
 274                FHostIP:= TIPNamePair.Create(HostName, IPToStr(@DstSockAddr));
 275                SetSockTimeOut(FSockTimeOut);
 276             end
 277             else
 278                CloseSocket(FSocket);
 279
 280          end
 281          else
 282             CloseSocket(FSocket);
 283
 284       end;
 285
 286       FreeHost(GAIResult);
 287    end;
 288    Result:= FConnected;
 289 end;
 290
 291 procedure TTCPConnection.Disconnect;
 292 begin
 293    fpShutdown(FSocket, 2);
 294    CloseSocket(FSocket);
 295    FSocket:= -1;
 296    FHostIP.Free;
 297    FConnected:= false;
 298 end;
 299
 300 procedure TTCPConnection.ReverseDNSLookup;
 301 { Performs a reverse DNS lookup, and updates the HostIP structure. }
 302 var NHostIP: TIPNamePair;
 303 begin
 304    if FConnected then begin
 305       NHostIP:= TIPNamePair.Create(ResolveIP(PSockAddr(@DstSockAddr)), FHostIP.IP);
 306       FHostIP.Free;
 307       FHostIP:= NHostIP;
 308    end;
 309 end;
 310
 311 function TTCPConnection.VerifyFCrDNS: boolean;
 312 var GAIResult: TGAIResult; ai: PAddrInfo;
 313 begin
 314    Result:= false;
 315    GAIResult:= ResolveHost(HostIP.Name, AF_UNSPEC);
 316    if GAIResult.GAIError = 0 then begin
 317       ai:= GAIResult.AddrInfo;
 318       { One of the addresses must match. }
 319       while (ai <> nil) and not Result do begin
 320          Result:= IPToStr(ai^.ai_addr) = HostIP.IP;
 321          ai:= ai^.ai_next;
 322       end;
 323    end;
 324 end;
 325
 326 procedure TTCPConnection.SetSockTimeOut(TimeOut: DWord);
 327 begin
 328    FSockTimeOut:= TimeOut;
 329    if Connected then begin
 330       fpSetSockOpt(FSocket, SOL_SOCKET, SO_RCVTIMEO, @FSockTimeOut, SizeOf(FSockTimeOut));
 331       fpSetSockOpt(FSocket, SOL_SOCKET, SO_SNDTIMEO, @FSockTimeOut, SizeOf(FSockTimeOut));
 332    end;
 333 end;
 334
 335 function TTCPConnection.ReadBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 336 begin
 337    Result:= fpRecv(FSocket, PtrBuffer, Len, 0);
 338 end;
 339
 340 function TTCPConnection.WriteBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 341 begin
 342    Result:= fpSend(FSocket, PtrBuffer, Len, 0);
 343 end;
 344
 345 function TTCPConnection.ReadLn(var Line: string): boolean;
 346 begin
 347    Result:= SockReadLn(FSocket, Line);
 348 end;
 349
 350 function TTCPConnection.WriteLn(const Line: string): boolean;
 351 begin
 352    Result:= SockWriteLn(FSocket, Line);
 353 end;
 354
 355
 356 function TTCPRFCConnection.ReadCommand(var Command: shortstring; var Prms: string): boolean;
 357 begin
 358    Result:= NetRFC.ReadCommand(FSocket, Command, Prms);
 359 end;
 360
 361 function TTCPRFCConnection.ReadResponse(Response: TRFCReply): boolean;
 362 begin
 363    Result:= NetRFC.ReadResponse(FSocket, Response);
 364 end;
 365
 366 function TTCPRFCConnection.SendCommand(Command: shortstring): boolean;
 367 begin
 368    Result:= NetRFC.SendCommand(FSocket, Command);
 369 end;
 370
 371 function TTCPRFCConnection.SendCommand(Command: shortstring; Prms: string): boolean;
 372 begin
 373    Result:= NetRFC.SendCommand(FSocket, Command, Prms);
 374 end;
 375
 376 function TTCPRFCConnection.SendResponse(Response: TRFCReply): boolean;
 377 begin
 378    Result:= NetRFC.SendResponse(FSocket, Response);
 379 end;
 380
 381
 382 procedure TTCPAcceptor.Execute;
 383 begin
 384    FHandler(FTCPConnection);
 385 end;
 386
 387
 388 function TTCPListener.StartListen: boolean;
 389 var GAIResult: TGAIResult;
 390 begin
 391    FListenSocket:= fpSocket(FFamily, SOCK_STREAM, 0);
 392    if FListenSocket <> -1 then begin
 393       GAIResult:= ResolveHost(FListenAddress, FFamily);
 394       if GAIResult.GAIError = 0 then begin
 395          Move(GAIResult.AddrInfo^.ai_addr^, SockAddr, GAIResult.AddrInfo^.ai_addrlen);
 396          SockAddr.sin6_port:= htons(FListenPort);
 397
 398          if fpBind(FListenSocket, @SockAddr, GAIResult.AddrInfo^.ai_addrlen) <> -1 then begin
 399             { It seems the maximum connection value isn't enforced by the
 400               Free Pascal library, so this 512 is a constant, dummy value. }
 401             if fpListen(FListenSocket, 512) <> -1 then begin
 402                Result:= true;
 403                Start;
 404             end
 405             else Result:= false;
 406          end
 407          else Result:= false;
 408
 409          FreeHost(GAIResult);
 410       end
 411           else Result:= false;
 412    end
 413    else Result:= false;
 414 end;
 415
 416 procedure TTCPListener.StopListen;
 417 begin
 418    Terminate;
 419    KillThread(Handle);
 420 end;
 421
 422 procedure TTCPListener.Execute;
 423 var ClientSocket: socket; AcceptFailCount: word; Len: longint;
 424     TCPConnection: TTCPConnection;
 425 begin
 426    { Now, accept connections. }
 427    AcceptFailCount:= 0;
 428    while not Terminated do begin
 429       Len:= SizeOf(SockAddr);
 430       ClientSocket:= fpAccept(FListenSocket, @SockAddr, @Len);
 431       if ClientSocket <> -1 then begin
 432          AcceptFailCount:= 0;
 433
 434          { Creates the requested TTCPConnection object for the accepted
 435            connection. }
 436          case FFeatureRequest of
 437          NET_TCP_BASIC:
 438             TCPConnection:= TTCPConnection.Create(ClientSocket);
 439          NET_TCP_RFCSUPPORT:
 440             TCPConnection:= TTCPRFCConnection.Create(ClientSocket);
 441          end;
 442
 443          { Then start a new thread with the connection handler. }
 444          TTCPAcceptor.Create(HandleClient, TCPConnection);
 445       end
 446       else begin
 447          Inc(AcceptFailCount);
 448          if AcceptFailCount >= 512 then Terminate;
 449       end;
 450    end;
 451 end;
 452
 453
 454 end.