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, SysUtils, 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: TSockAddr); overload;
  58       destructor Destroy; override;
  59    private
  60       FConnected: boolean;
  61       FSocket: socket;
  62       FHostIP: TIPNamePair;
  63       FSockTimeOut: DWord;
  64       SockAddr: TSockAddr;
  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; FeatureRequest: word);
 103       {destructor Destroy; override;}
 104    protected
 105       FFeatureRequest: word;
 106       FListenAddress: string;
 107       FListenPort: word;
 108       FListenSocket: socket;
 109       SockAddr: TSockAddr;
 110       procedure HandleClient(Connection: TTCPConnection); virtual; abstract;
 111       procedure Execute; override;
 112    public
 113       property ListenAddress: string read FListenAddress;
 114       property ListenPort: word read FListenPort;
 115       function GetSockAddrStr: string;
 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: TSockAddr);
 142 { Use an already connected socket. }
 143 begin
 144    inherited Create;
 145    FSocket:= Socket;
 146    SockAddr:= Addr;
 147    FHostIP:= TIPNamePair.Create('', NetAddrToStr(Addr.sin_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; FeatureRequest: word);
 169 begin
 170    FListenAddress:= Address;
 171    FListenPort:= Port;
 172    FFeatureRequest:= FeatureRequest;
 173    FreeOnTerminate:= false;
 174    FillChar(SockAddr, SizeOf(SockAddr), 0);
 175    inherited Create(true);
 176 end;
 177
 178
 179 function TTCPConnection.Connect(const HostName: string; Port: word): boolean;
 180 { Resolves the given hostname, and tries to connect it on the given port. }
 181 var GAIResult: TGAIResult;
 182 begin
 183    FSocket:= fpSocket(af_inet, sock_stream, 0);
 184    if (FSocket <> -1) then begin
 185       GAIResult:= ResolveHost(HostName);
 186           if GAIResult.GAIError = 0 then begin
 187              SockAddr:= GAIResult.AddrInfo^.ai_addr^;
 188                  SockAddr.sin_port:= htons(Port);
 189
 190                  if SockAddr.sin_addr.s_addr <> 0 then
 191                     { Try to initiate connection. }
 192                     FConnected:= fpConnect(FSocket, @SockAddr, SizeOf(SockAddr)) <> -1;
 193
 194                  if FConnected then begin
 195                     FHostIP:= TIPNamePair.Create(HostName, NetAddrToStr(SockAddr.sin_addr));
 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);
 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:= NetAddrToStr(ai^.ai_addr^.sin_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.GetSockAddrStr: string;
 305 begin
 306    Result:= NetAddrToStr(SockAddr.sin_addr) + ':' + IntToStr(ntohs(SockAddr.sin_port));
 307 end;
 308
 309 function TTCPListener.StartListen: boolean;
 310 var GAIResult: TGAIResult;
 311 begin
 312    FListenSocket:= fpSocket(af_inet, sock_stream, 0);
 313    if FListenSocket <> -1 then begin
 314       GAIResult:= ResolveHost(FListenAddress);
 315           if GAIResult.GAIError = 0 then begin
 316              SockAddr:= GAIResult.AddrInfo^.ai_addr^;
 317                  SockAddr.sin_port:= htons(FListenPort);
 318
 319          if fpBind(FListenSocket, @SockAddr, SizeOf(SockAddr)) <> -1 then begin
 320             { It seems the maximum connection value isn't enforced by the
 321               Free Pascal library, so this 512 is a constant, dummy value. }
 322             if fpListen(FListenSocket, 512) <> -1 then begin
 323                Result:= true;
 324                Start;
 325             end
 326             else Result:= false;
 327          end
 328          else Result:= false;
 329
 330          FreeHost(GAIResult);
 331       end
 332           else Result:= false;
 333    end
 334    else Result:= false;
 335 end;
 336
 337 procedure TTCPListener.StopListen;
 338 begin
 339    Terminate;
 340    KillThread(Handle);
 341 end;
 342
 343 procedure TTCPListener.Execute;
 344 var ClientSocket: socket; AcceptFailCount: word; Len: longint;
 345     TCPConnection: TTCPConnection;
 346 begin
 347    { Now, accept connections. }
 348    AcceptFailCount:= 0;
 349    while not Terminated do begin
 350       Len:= SizeOf(SockAddr);
 351       ClientSocket:= fpAccept(FListenSocket, @SockAddr, @Len);
 352       if ClientSocket <> -1 then begin
 353          AcceptFailCount:= 0;
 354
 355          { Creates the requested TTCPConnection object for the accepted
 356            connection. }
 357          case FFeatureRequest of
 358          NET_TCP_BASIC:
 359             TCPConnection:= TTCPConnection.Create(ClientSocket, SockAddr);
 360          NET_TCP_RFCSUPPORT:
 361             TCPConnection:= TTCPRFCConnection.Create(ClientSocket, SockAddr);
 362          end;
 363
 364          { Then start a new thread with the connection handler. }
 365          TTCPAcceptor.Create(HandleClient, TCPConnection);
 366       end
 367       else begin
 368          Inc(AcceptFailCount);
 369          if AcceptFailCount >= 512 then Terminate;
 370       end;
 371    end;
 372 end;
 373
 374
 375 end.