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    { Connection feature requests: }
  45    NET_TCP_BASIC        =  0;
  46    NET_TCP_RFCSUPPORT   =  1;
  47
  48    { Default socket timeout: }
  49    DEF_SOCK_TIMEOUT     =  5 * 60000;     { 5 minutes. }
  50
  51
  52 type
  53
  54    TTCPConnection = class
  55       constructor Create; overload;
  56       constructor Create(const HostName: string; Port: word); overload;
  57       constructor Create(Socket: socket; const Addr: TSockAddr6); overload;
  58       destructor Destroy; override;
  59    private
  60       FConnected: boolean;
  61       FSocket: socket;
  62       FHostIP: TIPNamePair;
  63       FSockTimeOut: DWord;
  64       SockAddr: TSockAddr6;
  65    public
  66       function Connect(const HostName: string; Port: word): boolean;
  67       procedure Disconnect;
  68       procedure ReverseDNSLookup;
  69       function VerifyFCrDNS: boolean;
  70       procedure SetSockTimeOut(TimeOut: DWord);
  71       function ReadBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
  72       function WriteBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
  73       function ReadLn(var Line: string): boolean;
  74       function WriteLn(const Line: string): boolean;
  75       property Connected: boolean read FConnected;
  76       property Socket: socket read FSocket;
  77       property HostIP: TIPNamePair read FHostIP;
  78       property SockTimeOut: DWord read FSockTimeOut write SetSockTimeOut;
  79    end;
  80
  81    TTCPRFCConnection = class(TTCPConnection)
  82    public
  83       function ReadCommand(var Command: shortstring; var Prms: string): boolean;
  84       function ReadResponse(Response: TRFCReply): boolean;
  85       function SendCommand(Command: shortstring): boolean; overload;
  86       function SendCommand(Command: shortstring; Prms: string): boolean; overload;
  87       function SendResponse(Response: TRFCReply): boolean;
  88    end;
  89
  90
  91    TTCPAcceptHandler = procedure(Connection: TTCPConnection) of object;
  92
  93    TTCPAcceptor = class(TThread)
  94       constructor Create(Handler: TTCPAcceptHandler; TCPConnection: TTCPConnection);
  95    protected
  96       FHandler: TTCPAcceptHandler;
  97       FTCPConnection: TTCPConnection;
  98       procedure Execute; override;
  99    end;
 100
 101    TTCPListener = class(TThread)
 102       constructor Create(const Address: string; Port: word; Family: word; FeatureRequest: word);
 103       {destructor Destroy; override;}
 104    private
 105       FFeatureRequest: word;
 106       FFamily: word;
 107       FListenAddress: string;
 108       FListenPort: word;
 109       FListenSocket: socket;
 110       SockAddr: TSockAddr6;
 111    protected
 112       procedure HandleClient(Connection: TTCPConnection); virtual; abstract;
 113       procedure Execute; override;
 114    public
 115       property ListenPort: word read FListenPort;
 116       function StartListen: boolean;
 117       procedure StopListen;
 118    end;
 119
 120
 121
 122 implementation
 123
 124
 125 constructor TTCPConnection.Create;
 126 { Create an instance, but don't connect to anywhere yet. }
 127 begin
 128    inherited Create;
 129    FConnected:= false;
 130    FSocket:= -1;
 131    FSockTimeOut:= DEF_SOCK_TIMEOUT;
 132 end;
 133
 134 constructor TTCPConnection.Create(const HostName: string; Port: word);
 135 { Connect to the given port on the given hostname. }
 136 begin
 137    Create;
 138    Connect(HostName, Port);
 139 end;
 140
 141 constructor TTCPConnection.Create(Socket: socket; const Addr: TSockAddr6);
 142 { Use an already connected socket. }
 143 begin
 144    inherited Create;
 145    FSocket:= Socket;
 146    SockAddr:= Addr;
 147    FHostIP:= TIPNamePair.Create('', IPToStr(@Addr));
 148    FConnected:= true;
 149 end;
 150
 151 destructor TTCPConnection.Destroy;
 152 begin
 153    if FConnected then Disconnect;
 154    inherited Destroy;
 155 end;
 156
 157
 158 constructor TTCPAcceptor.Create(Handler: TTCPAcceptHandler; TCPConnection: TTCPConnection);
 159 { Start a connection handler on a distinct thread. }
 160 begin
 161    FHandler:= Handler;
 162    FTCPConnection:= TCPConnection;
 163    FreeOnTerminate:= true;
 164    inherited Create(false);
 165 end;
 166
 167
 168 constructor TTCPListener.Create(const Address: string; Port: word; Family: word; FeatureRequest: word);
 169 begin
 170    FFamily:= Family;
 171    FListenAddress:= Address;
 172    FListenPort:= Port;
 173    FFeatureRequest:= FeatureRequest;
 174    FreeOnTerminate:= false;
 175    FillChar(SockAddr, SizeOf(SockAddr), 0);
 176    inherited Create(true);
 177 end;
 178
 179
 180 function TTCPConnection.Connect(const HostName: string; Port: word): boolean;
 181 { Resolves the given hostname, and tries to connect it on the given port. }
 182 var GAIResult: TGAIResult;
 183 begin
 184    FSocket:= fpSocket(af_inet, sock_stream, 0);
 185    if (FSocket <> -1) then begin
 186       GAIResult:= ResolveHost(HostName, AF_UNSPEC);
 187       if GAIResult.GAIError = 0 then begin
 188          Move(GAIResult.AddrInfo^.ai_addr^, SockAddr, GAIResult.AddrInfo^.ai_addrlen);
 189          SockAddr.sin6_port:= htons(Port);
 190
 191          { Try to initiate connection. }
 192          FConnected:= fpConnect(FSocket, @SockAddr, GAIResult.AddrInfo^.ai_addrlen) <> -1;
 193
 194                  if FConnected then begin
 195                     FHostIP:= TIPNamePair.Create(HostName, IPToStr(@SockAddr));
 196                     SetSockTimeOut(FSockTimeOut);
 197                  end
 198                  else
 199                     CloseSocket(FSocket);
 200
 201          FreeHost(GAIResult);
 202       end;
 203    end;
 204    Result:= FConnected;
 205 end;
 206
 207 procedure TTCPConnection.Disconnect;
 208 begin
 209    fpShutdown(FSocket, 2);
 210    CloseSocket(FSocket);
 211    FSocket:= -1;
 212    FHostIP.Free;
 213    FConnected:= false;
 214 end;
 215
 216 procedure TTCPConnection.ReverseDNSLookup;
 217 { Performs a reverse DNS lookup, and updates the HostIP structure. }
 218 var NHostIP: TIPNamePair;
 219 begin
 220    if FConnected then begin
 221       NHostIP:= TIPNamePair.Create(ResolveIP(@SockAddr), FHostIP.IP);
 222       FHostIP.Free;
 223       FHostIP:= NHostIP;
 224    end;
 225 end;
 226
 227 function TTCPConnection.VerifyFCrDNS: boolean;
 228 var GAIResult: TGAIResult; ai: PAddrInfo;
 229 begin
 230    Result:= false;
 231    GAIResult:= ResolveHost(HostIP.Name, AF_UNSPEC);
 232    if GAIResult.GAIError = 0 then begin
 233       ai:= GAIResult.AddrInfo;
 234       { One of the addresses must match. }
 235       while (ai <> nil) and not Result do begin
 236          Result:= IPToStr(ai^.ai_addr) = HostIP.IP;
 237          ai:= ai^.ai_next;
 238       end;
 239    end;
 240 end;
 241
 242 procedure TTCPConnection.SetSockTimeOut(TimeOut: DWord);
 243 begin
 244    FSockTimeOut:= TimeOut;
 245    if Connected then begin
 246       fpSetSockOpt(FSocket, SOL_SOCKET, SO_RCVTIMEO, @FSockTimeOut, SizeOf(FSockTimeOut));
 247       fpSetSockOpt(FSocket, SOL_SOCKET, SO_SNDTIMEO, @FSockTimeOut, SizeOf(FSockTimeOut));
 248    end;
 249 end;
 250
 251 function TTCPConnection.ReadBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 252 begin
 253    Result:= fpRecv(FSocket, PtrBuffer, Len, 0);
 254 end;
 255
 256 function TTCPConnection.WriteBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 257 begin
 258    Result:= fpSend(FSocket, PtrBuffer, Len, 0);
 259 end;
 260
 261 function TTCPConnection.ReadLn(var Line: string): boolean;
 262 begin
 263    Result:= SockReadLn(FSocket, Line);
 264 end;
 265
 266 function TTCPConnection.WriteLn(const Line: string): boolean;
 267 begin
 268    Result:= SockWriteLn(FSocket, Line);
 269 end;
 270
 271
 272 function TTCPRFCConnection.ReadCommand(var Command: shortstring; var Prms: string): boolean;
 273 begin
 274    Result:= NetRFC.ReadCommand(FSocket, Command, Prms);
 275 end;
 276
 277 function TTCPRFCConnection.ReadResponse(Response: TRFCReply): boolean;
 278 begin
 279    Result:= NetRFC.ReadResponse(FSocket, Response);
 280 end;
 281
 282 function TTCPRFCConnection.SendCommand(Command: shortstring): boolean;
 283 begin
 284    Result:= NetRFC.SendCommand(FSocket, Command);
 285 end;
 286
 287 function TTCPRFCConnection.SendCommand(Command: shortstring; Prms: string): boolean;
 288 begin
 289    Result:= NetRFC.SendCommand(FSocket, Command, Prms);
 290 end;
 291
 292 function TTCPRFCConnection.SendResponse(Response: TRFCReply): boolean;
 293 begin
 294    Result:= NetRFC.SendResponse(FSocket, Response);
 295 end;
 296
 297
 298 procedure TTCPAcceptor.Execute;
 299 begin
 300    FHandler(FTCPConnection);
 301 end;
 302
 303
 304 function TTCPListener.StartListen: boolean;
 305 var GAIResult: TGAIResult;
 306 begin
 307    FListenSocket:= fpSocket(FFamily, SOCK_STREAM, 0);
 308    if FListenSocket <> -1 then begin
 309       GAIResult:= ResolveHost(FListenAddress, FFamily);
 310       if GAIResult.GAIError = 0 then begin
 311          Move(GAIResult.AddrInfo^.ai_addr^, SockAddr, GAIResult.AddrInfo^.ai_addrlen);
 312          SockAddr.sin6_port:= htons(FListenPort);
 313
 314          if fpBind(FListenSocket, @SockAddr, GAIResult.AddrInfo^.ai_addrlen) <> -1 then begin
 315             { It seems the maximum connection value isn't enforced by the
 316               Free Pascal library, so this 512 is a constant, dummy value. }
 317             if fpListen(FListenSocket, 512) <> -1 then begin
 318                Result:= true;
 319                Start;
 320             end
 321             else Result:= false;
 322          end
 323          else Result:= false;
 324
 325          FreeHost(GAIResult);
 326       end
 327           else Result:= false;
 328    end
 329    else Result:= false;
 330 end;
 331
 332 procedure TTCPListener.StopListen;
 333 begin
 334    Terminate;
 335    KillThread(Handle);
 336 end;
 337
 338 procedure TTCPListener.Execute;
 339 var ClientSocket: socket; AcceptFailCount: word; Len: longint;
 340     TCPConnection: TTCPConnection;
 341 begin
 342    { Now, accept connections. }
 343    AcceptFailCount:= 0;
 344    while not Terminated do begin
 345       Len:= SizeOf(SockAddr);
 346       ClientSocket:= fpAccept(FListenSocket, @SockAddr, @Len);
 347       if ClientSocket <> -1 then begin
 348          AcceptFailCount:= 0;
 349
 350          { Creates the requested TTCPConnection object for the accepted
 351            connection. }
 352          case FFeatureRequest of
 353          NET_TCP_BASIC:
 354             TCPConnection:= TTCPConnection.Create(ClientSocket, SockAddr);
 355          NET_TCP_RFCSUPPORT:
 356             TCPConnection:= TTCPRFCConnection.Create(ClientSocket, SockAddr);
 357          end;
 358
 359          { Then start a new thread with the connection handler. }
 360          TTCPAcceptor.Create(HandleClient, TCPConnection);
 361       end
 362       else begin
 363          Inc(AcceptFailCount);
 364          if AcceptFailCount >= 512 then Terminate;
 365       end;
 366    end;
 367 end;
 368
 369
 370 end.