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    FSocket:= fpSocket(af_inet, sock_stream, 0);
 192    if (FSocket <> -1) then begin
 193       GAIResult:= ResolveHost(HostName, AF_UNSPEC);
 194       if GAIResult.GAIError = 0 then begin
 195          Move(GAIResult.AddrInfo^.ai_addr^, SockAddr, GAIResult.AddrInfo^.ai_addrlen);
 196          SockAddr.sin6_port:= htons(Port);
 197
 198          { Try to initiate connection. }
 199          FConnected:= fpConnect(FSocket, @SockAddr, GAIResult.AddrInfo^.ai_addrlen) <> -1;
 200
 201                  if FConnected then begin
 202                     FHostIP:= TIPNamePair.Create(HostName, IPToStr(@SockAddr));
 203                     SetSockTimeOut(FSockTimeOut);
 204                  end
 205                  else
 206                     CloseSocket(FSocket);
 207
 208          FreeHost(GAIResult);
 209       end;
 210    end;
 211    Result:= FConnected;
 212 end;
 213
 214 procedure TTCPConnection.Disconnect;
 215 begin
 216    fpShutdown(FSocket, 2);
 217    CloseSocket(FSocket);
 218    FSocket:= -1;
 219    FHostIP.Free;
 220    FConnected:= false;
 221 end;
 222
 223 procedure TTCPConnection.ReverseDNSLookup;
 224 { Performs a reverse DNS lookup, and updates the HostIP structure. }
 225 var NHostIP: TIPNamePair;
 226 begin
 227    if FConnected then begin
 228       NHostIP:= TIPNamePair.Create(ResolveIP(PSockAddr(@SockAddr)), FHostIP.IP);
 229       FHostIP.Free;
 230       FHostIP:= NHostIP;
 231    end;
 232 end;
 233
 234 function TTCPConnection.VerifyFCrDNS: boolean;
 235 var GAIResult: TGAIResult; ai: PAddrInfo;
 236 begin
 237    Result:= false;
 238    GAIResult:= ResolveHost(HostIP.Name, AF_UNSPEC);
 239    if GAIResult.GAIError = 0 then begin
 240       ai:= GAIResult.AddrInfo;
 241       { One of the addresses must match. }
 242       while (ai <> nil) and not Result do begin
 243          Result:= IPToStr(ai^.ai_addr) = HostIP.IP;
 244          ai:= ai^.ai_next;
 245       end;
 246    end;
 247 end;
 248
 249 procedure TTCPConnection.SetSockTimeOut(TimeOut: DWord);
 250 begin
 251    FSockTimeOut:= TimeOut;
 252    if Connected then begin
 253       fpSetSockOpt(FSocket, SOL_SOCKET, SO_RCVTIMEO, @FSockTimeOut, SizeOf(FSockTimeOut));
 254       fpSetSockOpt(FSocket, SOL_SOCKET, SO_SNDTIMEO, @FSockTimeOut, SizeOf(FSockTimeOut));
 255    end;
 256 end;
 257
 258 function TTCPConnection.ReadBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 259 begin
 260    Result:= fpRecv(FSocket, PtrBuffer, Len, 0);
 261 end;
 262
 263 function TTCPConnection.WriteBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 264 begin
 265    Result:= fpSend(FSocket, PtrBuffer, Len, 0);
 266 end;
 267
 268 function TTCPConnection.ReadLn(var Line: string): boolean;
 269 begin
 270    Result:= SockReadLn(FSocket, Line);
 271 end;
 272
 273 function TTCPConnection.WriteLn(const Line: string): boolean;
 274 begin
 275    Result:= SockWriteLn(FSocket, Line);
 276 end;
 277
 278
 279 function TTCPRFCConnection.ReadCommand(var Command: shortstring; var Prms: string): boolean;
 280 begin
 281    Result:= NetRFC.ReadCommand(FSocket, Command, Prms);
 282 end;
 283
 284 function TTCPRFCConnection.ReadResponse(Response: TRFCReply): boolean;
 285 begin
 286    Result:= NetRFC.ReadResponse(FSocket, Response);
 287 end;
 288
 289 function TTCPRFCConnection.SendCommand(Command: shortstring): boolean;
 290 begin
 291    Result:= NetRFC.SendCommand(FSocket, Command);
 292 end;
 293
 294 function TTCPRFCConnection.SendCommand(Command: shortstring; Prms: string): boolean;
 295 begin
 296    Result:= NetRFC.SendCommand(FSocket, Command, Prms);
 297 end;
 298
 299 function TTCPRFCConnection.SendResponse(Response: TRFCReply): boolean;
 300 begin
 301    Result:= NetRFC.SendResponse(FSocket, Response);
 302 end;
 303
 304
 305 procedure TTCPAcceptor.Execute;
 306 begin
 307    FHandler(FTCPConnection);
 308 end;
 309
 310
 311 function TTCPListener.StartListen: boolean;
 312 var GAIResult: TGAIResult;
 313 begin
 314    FListenSocket:= fpSocket(FFamily, SOCK_STREAM, 0);
 315    if FListenSocket <> -1 then begin
 316       GAIResult:= ResolveHost(FListenAddress, FFamily);
 317       if GAIResult.GAIError = 0 then begin
 318          Move(GAIResult.AddrInfo^.ai_addr^, SockAddr, GAIResult.AddrInfo^.ai_addrlen);
 319          SockAddr.sin6_port:= htons(FListenPort);
 320
 321          if fpBind(FListenSocket, @SockAddr, GAIResult.AddrInfo^.ai_addrlen) <> -1 then begin
 322             { It seems the maximum connection value isn't enforced by the
 323               Free Pascal library, so this 512 is a constant, dummy value. }
 324             if fpListen(FListenSocket, 512) <> -1 then begin
 325                Result:= true;
 326                Start;
 327             end
 328             else Result:= false;
 329          end
 330          else Result:= false;
 331
 332          FreeHost(GAIResult);
 333       end
 334           else Result:= false;
 335    end
 336    else Result:= false;
 337 end;
 338
 339 procedure TTCPListener.StopListen;
 340 begin
 341    Terminate;
 342    KillThread(Handle);
 343 end;
 344
 345 procedure TTCPListener.Execute;
 346 var ClientSocket: socket; AcceptFailCount: word; Len: longint;
 347     TCPConnection: TTCPConnection;
 348 begin
 349    { Now, accept connections. }
 350    AcceptFailCount:= 0;
 351    while not Terminated do begin
 352       Len:= SizeOf(SockAddr);
 353       ClientSocket:= fpAccept(FListenSocket, @SockAddr, @Len);
 354       if ClientSocket <> -1 then begin
 355          AcceptFailCount:= 0;
 356
 357          { Creates the requested TTCPConnection object for the accepted
 358            connection. }
 359          case FFeatureRequest of
 360          NET_TCP_BASIC:
 361             TCPConnection:= TTCPConnection.Create(ClientSocket, SockAddr);
 362          NET_TCP_RFCSUPPORT:
 363             TCPConnection:= TTCPRFCConnection.Create(ClientSocket, SockAddr);
 364          end;
 365
 366          { Then start a new thread with the connection handler. }
 367          TTCPAcceptor.Create(HandleClient, TCPConnection);
 368       end
 369       else begin
 370          Inc(AcceptFailCount);
 371          if AcceptFailCount >= 512 then Terminate;
 372       end;
 373    end;
 374 end;
 375
 376
 377 end.