Network.pas

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