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, 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; const Addr: TSockAddr6); overload;
  65       destructor Destroy; override;
  66    private
  67       FConnected: boolean;
  68       FSocket: socket;
  69       FHostIP: TIPNamePair;
  70       FSockTimeOut: DWord;
  71       SockAddr: TSockAddr6;
  72    public
  73       function Connect(const HostName: string; Port: word): boolean;
  74       procedure Disconnect;
  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;
  86    end;
  87
  88    TTCPRFCConnection = class(TTCPConnection)
  89    public
  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;
  95    end;
  96
  97
  98    TTCPAcceptHandler = procedure(Connection: TTCPConnection) of object;
  99
 100    TTCPAcceptor = class(TThread)
 101       constructor Create(Handler: TTCPAcceptHandler; TCPConnection: TTCPConnection);
 102    protected
 103       FHandler: TTCPAcceptHandler;
 104       FTCPConnection: TTCPConnection;
 105       procedure Execute; override;
 106    end;
 107
 108    TTCPListener = class(TThread)
 109       constructor Create(const Address: string; Port: word; Family: word; FeatureRequest: word);
 110       {destructor Destroy; override;}
 111    private
 112       FFeatureRequest: word;
 113       FFamily: word;
 114       FListenAddress: string;
 115       FListenPort: word;
 116       FListenSocket: socket;
 117       SockAddr: TSockAddr6;
 118    protected
 119       procedure HandleClient(Connection: TTCPConnection); virtual; abstract;
 120       procedure Execute; override;
 121    public
 122       property ListenPort: word read FListenPort;
 123       function StartListen: boolean;
 124       procedure StopListen;
 125    end;
 126
 127
 128
 129 implementation
 130
 131
 132 constructor TTCPConnection.Create;
 133 { Create an instance, but don't connect to anywhere yet. }
 134 begin
 135    inherited Create;
 136    FConnected:= false;
 137    FSocket:= -1;
 138    FSockTimeOut:= DEF_SOCK_TIMEOUT;
 139 end;
 140
 141 constructor TTCPConnection.Create(const HostName: string; Port: word);
 142 { Connect to the given port on the given hostname. }
 143 begin
 144    Create;
 145    Connect(HostName, Port);
 146 end;
 147
 148 constructor TTCPConnection.Create(Socket: socket; const Addr: TSockAddr6);
 149 { Use an already connected socket. }
 150 begin
 151    inherited Create;
 152    FSocket:= Socket;
 153    SockAddr:= Addr;
 154    FHostIP:= TIPNamePair.Create('', IPToStr(@Addr));
 155    FConnected:= true;
 156 end;
 157
 158 destructor TTCPConnection.Destroy;
 159 begin
 160    if FConnected then Disconnect;
 161    inherited Destroy;
 162 end;
 163
 164
 165 constructor TTCPAcceptor.Create(Handler: TTCPAcceptHandler; TCPConnection: TTCPConnection);
 166 { Start a connection handler on a distinct thread. }
 167 begin
 168    FHandler:= Handler;
 169    FTCPConnection:= TCPConnection;
 170    FreeOnTerminate:= true;
 171    inherited Create(false);
 172 end;
 173
 174
 175 constructor TTCPListener.Create(const Address: string; Port: word; Family: word; FeatureRequest: word);
 176 begin
 177    FFamily:= Family;
 178    FListenAddress:= Address;
 179    FListenPort:= Port;
 180    FFeatureRequest:= FeatureRequest;
 181    FreeOnTerminate:= false;
 182    FillChar(SockAddr, SizeOf(SockAddr), 0);
 183    inherited Create(true);
 184 end;
 185
 186
 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;
 190 begin
 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);
 195
 196       { Create socket. }
 197       FSocket:= fpSocket(GAIResult.AddrInfo^.ai_family, SOCK_STREAM, 0);
 198
 199       if (FSocket <> -1) then begin
 200
 201          { Try to initiate connection. }
 202          FConnected:= fpConnect(FSocket, @SockAddr, GAIResult.AddrInfo^.ai_addrlen) <> -1;
 203
 204          if FConnected then begin
 205             FHostIP:= TIPNamePair.Create(HostName, IPToStr(@SockAddr));
 206             SetSockTimeOut(FSockTimeOut);
 207          end
 208          else
 209             CloseSocket(FSocket);
 210
 211       end;
 212
 213       FreeHost(GAIResult);
 214    end;
 215    Result:= FConnected;
 216 end;
 217
 218 procedure TTCPConnection.Disconnect;
 219 begin
 220    fpShutdown(FSocket, 2);
 221    CloseSocket(FSocket);
 222    FSocket:= -1;
 223    FHostIP.Free;
 224    FConnected:= false;
 225 end;
 226
 227 procedure TTCPConnection.ReverseDNSLookup;
 228 { Performs a reverse DNS lookup, and updates the HostIP structure. }
 229 var NHostIP: TIPNamePair;
 230 begin
 231    if FConnected then begin
 232       NHostIP:= TIPNamePair.Create(ResolveIP(PSockAddr(@SockAddr)), FHostIP.IP);
 233       FHostIP.Free;
 234       FHostIP:= NHostIP;
 235    end;
 236 end;
 237
 238 function TTCPConnection.VerifyFCrDNS: boolean;
 239 var GAIResult: TGAIResult; ai: PAddrInfo;
 240 begin
 241    Result:= false;
 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;
 248          ai:= ai^.ai_next;
 249       end;
 250    end;
 251 end;
 252
 253 procedure TTCPConnection.SetSockTimeOut(TimeOut: DWord);
 254 begin
 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));
 259    end;
 260 end;
 261
 262 function TTCPConnection.ReadBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 263 begin
 264    Result:= fpRecv(FSocket, PtrBuffer, Len, 0);
 265 end;
 266
 267 function TTCPConnection.WriteBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 268 begin
 269    Result:= fpSend(FSocket, PtrBuffer, Len, 0);
 270 end;
 271
 272 function TTCPConnection.ReadLn(var Line: string): boolean;
 273 begin
 274    Result:= SockReadLn(FSocket, Line);
 275 end;
 276
 277 function TTCPConnection.WriteLn(const Line: string): boolean;
 278 begin
 279    Result:= SockWriteLn(FSocket, Line);
 280 end;
 281
 282
 283 function TTCPRFCConnection.ReadCommand(var Command: shortstring; var Prms: string): boolean;
 284 begin
 285    Result:= NetRFC.ReadCommand(FSocket, Command, Prms);
 286 end;
 287
 288 function TTCPRFCConnection.ReadResponse(Response: TRFCReply): boolean;
 289 begin
 290    Result:= NetRFC.ReadResponse(FSocket, Response);
 291 end;
 292
 293 function TTCPRFCConnection.SendCommand(Command: shortstring): boolean;
 294 begin
 295    Result:= NetRFC.SendCommand(FSocket, Command);
 296 end;
 297
 298 function TTCPRFCConnection.SendCommand(Command: shortstring; Prms: string): boolean;
 299 begin
 300    Result:= NetRFC.SendCommand(FSocket, Command, Prms);
 301 end;
 302
 303 function TTCPRFCConnection.SendResponse(Response: TRFCReply): boolean;
 304 begin
 305    Result:= NetRFC.SendResponse(FSocket, Response);
 306 end;
 307
 308
 309 procedure TTCPAcceptor.Execute;
 310 begin
 311    FHandler(FTCPConnection);
 312 end;
 313
 314
 315 function TTCPListener.StartListen: boolean;
 316 var GAIResult: TGAIResult;
 317 begin
 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);
 324
 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
 329                Result:= true;
 330                Start;
 331             end
 332             else Result:= false;
 333          end
 334          else Result:= false;
 335
 336          FreeHost(GAIResult);
 337       end
 338           else Result:= false;
 339    end
 340    else Result:= false;
 341 end;
 342
 343 procedure TTCPListener.StopListen;
 344 begin
 345    Terminate;
 346    KillThread(Handle);
 347 end;
 348
 349 procedure TTCPListener.Execute;
 350 var ClientSocket: socket; AcceptFailCount: word; Len: longint;
 351     TCPConnection: TTCPConnection;
 352 begin
 353    { Now, accept connections. }
 354    AcceptFailCount:= 0;
 355    while not Terminated do begin
 356       Len:= SizeOf(SockAddr);
 357       ClientSocket:= fpAccept(FListenSocket, @SockAddr, @Len);
 358       if ClientSocket <> -1 then begin
 359          AcceptFailCount:= 0;
 360
 361          { Creates the requested TTCPConnection object for the accepted
 362            connection. }
 363          case FFeatureRequest of
 364          NET_TCP_BASIC:
 365             TCPConnection:= TTCPConnection.Create(ClientSocket, SockAddr);
 366          NET_TCP_RFCSUPPORT:
 367             TCPConnection:= TTCPRFCConnection.Create(ClientSocket, SockAddr);
 368          end;
 369
 370          { Then start a new thread with the connection handler. }
 371          TTCPAcceptor.Create(HandleClient, TCPConnection);
 372       end
 373       else begin
 374          Inc(AcceptFailCount);
 375          if AcceptFailCount >= 512 then Terminate;
 376       end;
 377    end;
 378 end;
 379
 380
 381 end.