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: TSockAddr); overload;
  58       destructor Destroy; override;
  59    private
  60       FConnected: boolean;
  61       FSocket: socket;
  62       FHostIP: TIPNamePair;
  63       FSockTimeOut: DWord;
  64       sAddr: 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    private
 105       FFeatureRequest: word;
 106       FListenAddress: string;
 107       FListenPort: word;
 108       FListenSocket: socket;
 109       sAddr: TSockAddr;
 110    protected
 111       procedure HandleClient(Connection: TTCPConnection); virtual; abstract;
 112       procedure Execute; override;
 113    public
 114       property ListenPort: word read FListenPort;
 115       function StartListen: boolean;
 116       procedure StopListen;
 117    end;
 118
 119
 120
 121 implementation
 122
 123
 124 constructor TTCPConnection.Create;
 125 { Create an instance, but don't connect to anywhere yet. }
 126 begin
 127    inherited Create;
 128    FConnected:= false;
 129    FSocket:= -1;
 130    FSockTimeOut:= DEF_SOCK_TIMEOUT;
 131 end;
 132
 133 constructor TTCPConnection.Create(const HostName: string; Port: word);
 134 { Connect to the given port on the given hostname. }
 135 begin
 136    inherited Create;
 137    Connect(HostName, Port);
 138 end;
 139
 140 constructor TTCPConnection.Create(Socket: socket; const Addr: TSockAddr);
 141 { Use an already connected socket. }
 142 begin
 143    inherited Create;
 144    FSocket:= Socket;
 145    sAddr:= Addr;
 146    FHostIP:= TIPNamePair.Create('', NetAddrToStr(Addr.sin_addr));
 147    FConnected:= true;
 148 end;
 149
 150 destructor TTCPConnection.Destroy;
 151 begin
 152    if FConnected then Disconnect;
 153    inherited Destroy;
 154 end;
 155
 156
 157 constructor TTCPAcceptor.Create(Handler: TTCPAcceptHandler; TCPConnection: TTCPConnection);
 158 { Start a connection handler on a distinct thread. }
 159 begin
 160    FHandler:= Handler;
 161    FTCPConnection:= TCPConnection;
 162    FreeOnTerminate:= true;
 163    inherited Create(false);
 164 end;
 165
 166
 167 constructor TTCPListener.Create(const Address: string; Port: word; FeatureRequest: word);
 168 begin
 169    FListenAddress:= Address;
 170    FListenPort:= Port;
 171    FFeatureRequest:= FeatureRequest;
 172    FreeOnTerminate:= false;
 173    inherited Create(true);
 174 end;
 175
 176
 177 function TTCPConnection.Connect(const HostName: string; Port: word): boolean;
 178 { Resolves the given hostname, and tries to connect it on the given port. }
 179 begin
 180    FSocket:= fpSocket(af_inet, sock_stream, 0);
 181    if (FSocket <> -1) then begin
 182       with sAddr do begin
 183          sin_family:= af_inet;
 184          sin_port:= htons(Port);
 185          { Resolve hostname to IP address. }
 186          sin_addr:= ResolveHost(HostName);
 187       end;
 188
 189       if sAddr.sin_addr.s_addr <> 0 then
 190          { Try to initiate connection. }
 191          FConnected:= fpConnect(FSocket, @sAddr, SizeOf(sAddr)) <> -1;
 192
 193       if FConnected then begin
 194          FHostIP:= TIPNamePair.Create(HostName, NetAddrToStr(sAddr.sin_addr));
 195          SetSockTimeOut(FSockTimeOut);
 196       end
 197       else
 198          CloseSocket(FSocket);
 199    end;
 200    Result:= FConnected;
 201 end;
 202
 203 procedure TTCPConnection.Disconnect;
 204 begin
 205    fpShutdown(FSocket, 2);
 206    CloseSocket(FSocket);
 207    FSocket:= -1;
 208    FHostIP.Free;
 209    FConnected:= false;
 210 end;
 211
 212 procedure TTCPConnection.ReverseDNSLookup;
 213 { Performs a reverse DNS lookup, and updates the HostIP structure. }
 214 var NHostIP: TIPNamePair;
 215 begin
 216    if FConnected then begin
 217       NHostIP:= TIPNamePair.Create(ResolveIP(sAddr.sin_addr), FHostIP.IP);
 218       FHostIP.Free;
 219       FHostIP:= NHostIP;
 220    end;
 221 end;
 222
 223 function TTCPConnection.VerifyFCrDNS: boolean;
 224 begin
 225    Result:= NetAddrToStr(ResolveHost(HostIP.Name)) = HostIP.IP;
 226 end;
 227
 228 procedure TTCPConnection.SetSockTimeOut(TimeOut: DWord);
 229 begin
 230    FSockTimeOut:= TimeOut;
 231    if Connected then begin
 232       fpSetSockOpt(FSocket, SOL_SOCKET, SO_RCVTIMEO, @FSockTimeOut, SizeOf(FSockTimeOut));
 233       fpSetSockOpt(FSocket, SOL_SOCKET, SO_SNDTIMEO, @FSockTimeOut, SizeOf(FSockTimeOut));
 234    end;
 235 end;
 236
 237 function TTCPConnection.ReadBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 238 begin
 239    Result:= fpRecv(FSocket, PtrBuffer, Len, 0);
 240 end;
 241
 242 function TTCPConnection.WriteBuffer(PtrBuffer: pointer; Len: size_t): ssize_t;
 243 begin
 244    Result:= fpSend(FSocket, PtrBuffer, Len, 0);
 245 end;
 246
 247 function TTCPConnection.ReadLn(var Line: string): boolean;
 248 begin
 249    Result:= SockReadLn(FSocket, Line);
 250 end;
 251
 252 function TTCPConnection.WriteLn(const Line: string): boolean;
 253 begin
 254    Result:= SockWriteLn(FSocket, Line);
 255 end;
 256
 257
 258 function TTCPRFCConnection.ReadCommand(var Command: shortstring; var Prms: string): boolean;
 259 begin
 260    Result:= NetRFC.ReadCommand(FSocket, Command, Prms);
 261 end;
 262
 263 function TTCPRFCConnection.ReadResponse(Response: TRFCReply): boolean;
 264 begin
 265    Result:= NetRFC.ReadResponse(FSocket, Response);
 266 end;
 267
 268 function TTCPRFCConnection.SendCommand(Command: shortstring): boolean;
 269 begin
 270    Result:= NetRFC.SendCommand(FSocket, Command);
 271 end;
 272
 273 function TTCPRFCConnection.SendCommand(Command: shortstring; Prms: string): boolean;
 274 begin
 275    Result:= NetRFC.SendCommand(FSocket, Command, Prms);
 276 end;
 277
 278 function TTCPRFCConnection.SendResponse(Response: TRFCReply): boolean;
 279 begin
 280    Result:= NetRFC.SendResponse(FSocket, Response);
 281 end;
 282
 283
 284 procedure TTCPAcceptor.Execute;
 285 begin
 286    FHandler(FTCPConnection);
 287 end;
 288
 289
 290 function TTCPListener.StartListen: boolean;
 291 begin
 292    FListenSocket:= fpSocket(af_inet, sock_stream, 0);
 293    if FListenSocket <> -1 then begin
 294       with sAddr do begin
 295          sin_family:= af_inet;
 296          sin_port:= htons(FListenPort);
 297          sin_addr:= ResolveHost(FListenAddress);
 298       end;
 299       if fpBind(FListenSocket, @sAddr, sizeof(sAddr)) <> -1 then begin
 300          { It seems the maximum connection value isn't enforced by the
 301            Free Pascal library, so this 512 is a constant, dummy value. }
 302          if fpListen(FListenSocket, 512) <> -1 then begin
 303             Result:= true;
 304             Start;
 305          end
 306          else Result:= false;
 307       end
 308       else Result:= false;
 309    end
 310    else Result:= false;
 311 end;
 312
 313 procedure TTCPListener.StopListen;
 314 begin
 315    Terminate;
 316    KillThread(Handle);
 317 end;
 318
 319 procedure TTCPListener.Execute;
 320 var ClientSocket: socket; AcceptFailCount: word; Len: longint;
 321     TCPConnection: TTCPConnection;
 322 begin
 323    { Now, accept connections. }
 324    AcceptFailCount:= 0;
 325    while not Terminated do begin
 326       Len:= SizeOf(sAddr);
 327       ClientSocket:= fpAccept(FListenSocket, @sAddr, @Len);
 328       if ClientSocket <> -1 then begin
 329          AcceptFailCount:= 0;
 330
 331          { Creates the requested TTCPConnection object for the accepted
 332            connection. }
 333          case FFeatureRequest of
 334          NET_TCP_BASIC:
 335             TCPConnection:= TTCPConnection.Create(ClientSocket, sAddr);
 336          NET_TCP_RFCSUPPORT:
 337             TCPConnection:= TTCPRFCConnection.Create(ClientSocket, sAddr);
 338          end;
 339
 340          { Then start a new thread with the connection handler. }
 341          TTCPAcceptor.Create(HandleClient, TCPConnection);
 342       end
 343       else begin
 344          Inc(AcceptFailCount);
 345          if AcceptFailCount >= 512 then Terminate;
 346       end;
 347    end;
 348 end;
 349
 350
 351 end.