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