mysticbbs/mdl/m_socket_class.pas

680 lines
18 KiB
ObjectPascal

// ====================================================================
// Mystic BBS Software Copyright 1997-2013 By James Coyle
// ====================================================================
//
// This file is part of Mystic BBS.
//
// Mystic BBS is free software: you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation, either version 3 of the License, or
// (at your option) any later version.
//
// Mystic BBS is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with Mystic BBS. If not, see <http://www.gnu.org/licenses/>.
//
// ====================================================================
Unit m_Socket_Class;
{$link m_resolve_address.o}
{$linklib c}
{$I M_OPS.PAS}
Interface
Uses
{$IFDEF OS2}
WinSock,
{$ENDIF}
{$IFDEF WIN32}
Windows,
Winsock2,
{$ENDIF}
{$IFDEF UNIX}
BaseUnix,
cNetDB,
{$ENDIF}
Sockets,
m_DateTime,
m_Strings,
libmysticbbs;
Const
TSocketBufferSize = 8 * 1024 - 1;
Type
TSocketBuffer = Array[0..TSocketBufferSize] of Char;
TSocketClass = Class
FSocketHandle : LongInt;
FPort : LongInt;
FPeerName : String;
FPeerIP : String;
FHostIP : String;
FInBuf : TSocketBuffer;
FInBufPos : LongInt;
FInBufEnd : LongInt;
FOutBuf : TSocketBuffer;
FOutBufPos : LongInt;
FTelnetState : Byte;
FTelnetReply : Array[1..14] of Char;
FTelnetCmd : Char;
FTelnetSubCmd : Char;
FTelnetLen : Byte;
FTelnetEcho : Boolean;
FTelnetSubData : String;
FTelnetClient : Boolean;
FTelnetServer : Boolean;
FDisconnect : Boolean;
Constructor Create;
Destructor Destroy; Override;
Procedure Disconnect;
Function DataWaiting : Boolean;
Function WriteBuf (Var Buf; Len: LongInt) : LongInt;
Procedure BufFlush;
Procedure BufWriteChar (Ch: Char);
Procedure BufWriteStr (Str: String);
Function WriteLine (Str: String) : LongInt;
Function WriteStr (Str: String) : LongInt;
Function WriteFile (Str: String) : Boolean;
Function WriteBufEscaped (Var Buf: TSocketBuffer; Var Len: LongInt) : LongInt;
Procedure TelnetInBuffer (Var Buf: TSocketBuffer; Var Len: LongInt);
Function ReadBuf (Var Buf; Len: LongInt) : LongInt;
Function ReadLine (Var Str: String) : LongInt;
Function SetBlocking (Block: Boolean): LongInt;
Function WaitForData (TimeOut: LongInt) : LongInt;
Function Connect (Address: String; Port: Word) : Boolean;
Function ResolveAddress (Host: String; Remote_Address: PChar):Integer;
Procedure WaitInit (Port: Word);
Function WaitConnection : TSocketClass;
Procedure PurgeInputData;
Procedure PurgeOutputData;
Function PeekChar (Num: Byte) : Char;
Function ReadChar : Char;
Function WriteChar (Ch: Char) : LongInt;
Property SocketHandle : LongInt READ FSocketHandle WRITE FSocketHandle;
Property PeerPort : LongInt READ FPort WRITE FPort;
Property PeerName : String READ FPeerName WRITE FPeerName;
Property PeerIP : String READ FPeerIP WRITE FPeerIP;
Property HostIP : String READ FHostIP WRITE FHostIP;
End;
Implementation
{ TELNET NEGOTIATION CONSTANTS }
Const
Telnet_IAC = #255;
Telnet_DONT = #254;
Telnet_DO = #253;
Telnet_WONT = #252;
Telnet_WILL = #251;
Telnet_SB = #250;
Telnet_BINARY = #000;
Telnet_ECHO = #001;
Telnet_SE = #240;
Telnet_TERM = #24;
Telnet_SGA = #003;
FPSENDOPT = 0;
FPRECVOPT = 0;
Constructor TSocketClass.Create;
Begin
Inherited Create;
FSocketHandle := -1;
FPort := 0;
FPeerName := 'Unknown';
FPeerIP := FPeerName;
FInBufPos := 0;
FInBufEnd := 0;
FOutBufPos := 0;
FTelnetState := 0;
FTelnetEcho := False;
FTelnetClient := False;
FTelnetServer := False;
FDisconnect := True;
FHostIP := '';
End;
Destructor TSocketClass.Destroy;
Begin
If FDisconnect Then Disconnect;
Inherited Destroy;
End;
Procedure TSocketClass.PurgeOutputData;
Begin
FOutBufPos := 0;
End;
Procedure TSocketClass.PurgeInputData;
Begin
FInBufPos := 0;
FInBufEnd := 0;
End;
Procedure TSocketClass.Disconnect;
Begin
If FSocketHandle <> -1 Then Begin
fpShutdown(FSocketHandle, 2);
CloseSocket(FSocketHandle);
FSocketHandle := -1;
End;
End;
Function TSocketClass.DataWaiting : Boolean;
Begin
Result := (FInBufPos < FInBufEnd) or (WaitForData(0) > 0);
End;
Function TSocketClass.WriteBuf (Var Buf; Len: LongInt) : LongInt;
Begin
Result := fpSend(FSocketHandle, @Buf, Len, FPSENDOPT);
While (Result = -1) and (SocketError = ESOCKEWOULDBLOCK) Do Begin
WaitMS(10);
Result := fpSend(FSocketHandle, @Buf, Len, FPSENDOPT);
End;
End;
Procedure TSocketClass.BufFlush;
Begin
If FOutBufPos > 0 Then Begin
If FTelnetClient or FTelnetServer Then
WriteBufEscaped(FOutBuf, FOutBufPos)
Else
WriteBuf(FOutBuf, FOutBufPos);
FOutBufPos := 0;
End;
End;
Procedure TSocketClass.BufWriteChar (Ch: Char);
Begin
FOutBuf[FOutBufPos] := Ch;
Inc(FOutBufPos);
If FOutBufPos > TSocketBufferSize Then
BufFlush;
End;
Procedure TSocketClass.BufWriteStr (Str: String);
Var
Count : LongInt;
Begin
For Count := 1 to Length(Str) Do
BufWriteChar(Str[Count]);
End;
Function TSocketClass.WriteLine (Str: String) : LongInt;
Begin
Str := Str + #13#10;
Result := fpSend(FSocketHandle, @Str[1], Length(Str), FPSENDOPT);
End;
Function TSocketClass.WriteChar (Ch: Char) : LongInt;
Begin
Result := fpSend(FSocketHandle, @Ch, 1, FPSENDOPT);
End;
Function TSocketClass.WriteStr (Str: String) : LongInt;
Begin
Result := fpSend(FSocketHandle, @Str[1], Length(Str), FPSENDOPT);
End;
Function TSocketClass.WriteFile (Str: String) : Boolean;
Var
Buf : Array[1..4096] of Char;
Size : LongInt;
F : File;
Begin
Result := False;
FileMode := 66;
Assign (F, Str);
Reset (F, 1);
If IoResult <> 0 Then Exit;
Repeat
BlockRead (F, Buf, SizeOf(Buf), Size);
If Size = 0 Then Break;
If Buf[Size] = #26 Then Dec(Size);
WriteBuf (Buf, Size);
Until Size <> SizeOf(Buf);
Result := True;
End;
Function TSocketClass.WriteBufEscaped (Var Buf: TSocketBuffer; Var Len: LongInt) : LongInt;
Var
Temp : Array[0..TSocketBufferSize * 2] of Char;
TempPos : LongInt;
Count : LongInt;
Begin
TempPos := 0;
For Count := 0 to Len Do
If Buf[Count] = TELNET_IAC Then Begin
Temp[TempPos] := TELNET_IAC;
Inc (TempPos);
Temp[TempPos] := TELNET_IAC;
Inc (TempPos);
End Else Begin
Temp[TempPos] := Buf[Count];
Inc (TempPos);
End;
Dec(TempPos);
Result := fpSend(FSocketHandle, @Temp, TempPos, FPSENDOPT);
While (Result = -1) and (SocketError = ESOCKEWOULDBLOCK) Do Begin
WaitMS(10);
Result := fpSend(FSocketHandle, @Temp, TempPos, FPSENDOPT);
End;
End;
Procedure TSocketClass.TelnetInBuffer (Var Buf: TSocketBuffer; Var Len: LongInt);
Procedure SendCommand (YesNo, CmdType: Char);
Var
Reply : String[3];
Begin
Reply[1] := Telnet_IAC;
Reply[2] := Char(YesNo); {DO/DONT, WILL/WONT}
Reply[3] := CmdType;
fpSend (FSocketHandle, @Reply[1], 3, FPSENDOPT);
End;
Procedure SendData (CmdType: Char; Data: String);
Var
Reply : String;
DataLen : Byte;
Begin
DataLen := Length(Data);
Reply[1] := Telnet_IAC;
Reply[2] := Telnet_SB;
Reply[3] := CmdType;
Reply[4] := #0;
Move (Data[1], Reply[5], DataLen);
Reply[5 + DataLen] := #0;
Reply[6 + DataLen] := Telnet_IAC;
Reply[7 + DataLen] := Telnet_SE;
fpSend (FSocketHandle, @Reply[1], 7 + DataLen, FPSENDOPT);
End;
Var
Count : LongInt;
TempPos : LongInt;
Temp : TSocketBuffer;
ReplyGood : Char;
ReplyBad : Char;
Begin
TempPos := 0;
For Count := 0 to Len - 1 Do Begin
Case FTelnetState of
1 : If Buf[Count] = Telnet_IAC Then Begin
FTelnetState := 0;
Temp[TempPos] := Telnet_IAC;
Inc (TempPos);
End Else Begin
Inc (FTelnetState);
FTelnetCmd := Buf[Count];
End;
2 : Begin
FTelnetState := 0;
Case FTelnetCmd of
Telnet_WONT : Begin
// FTelnetSubCmd := Telnet_DONT;
// SockSend(FSocketHandle, FTelnetSubCmd, 1, 0);
End;
Telnet_DONT : Begin
// FTelnetSubCmd := Telnet_WONT;
// SockSend(FSocketHandle, FTelnetSubCmd, 1, 0);
End;
Telnet_SB : Begin
FTelnetState := 3;
FTelnetSubCmd := Buf[Count];
End;
Telnet_WILL,
Telnet_DO : Begin
If FTelnetCmd = Telnet_DO Then Begin
ReplyGood := Telnet_WILL;
ReplyBad := Telnet_WONT;
End Else Begin
ReplyGood := Telnet_DO;
ReplyBad := Telnet_DONT;
End;
If FTelnetClient Then Begin
Case Buf[Count] of
Telnet_BINARY,
Telnet_ECHO,
Telnet_SGA,
Telnet_TERM : SendCommand(ReplyGood, Buf[Count])
Else
SendCommand(ReplyBad, Buf[Count]);
End;
If Buf[Count] = Telnet_Echo Then
FTelnetEcho := (FTelnetCmd = Telnet_DO);
End Else Begin
Case Buf[Count] of
Telnet_ECHO : FTelnetEcho := True;
Telnet_SGA : ;
Else
SendCommand(ReplyBad, Buf[Count]);
End;
End;
End;
End;
End;
3 : If Buf[Count] = Telnet_SE Then Begin
If FTelnetClient Then
Case FTelnetSubCmd of
Telnet_TERM : SendData(Telnet_TERM, 'vt100');
End;
FTelnetState := 0;
FTelnetSubData := '';
End Else
FTelnetSubData := FTelnetSubData + Buf[Count];
Else
If Buf[Count] = Telnet_IAC Then Begin
Inc (FTelnetState);
End Else Begin
Temp[TempPos] := Buf[Count];
Inc (TempPos);
End;
End;
End;
Buf := Temp;
Len := TempPos;
End;
Function TSocketClass.ReadChar : Char;
Begin
ReadBuf(Result, 1);
End;
Function TSocketClass.PeekChar (Num: Byte) : Char;
Begin
If (FInBufPos = FInBufEnd) and DataWaiting Then
ReadBuf(Result, 0);
If FInBufPos + Num < FInBufEnd Then
Result := FInBuf[FInBufPos + Num];
End;
Function TSocketClass.ReadBuf (Var Buf; Len: LongInt) : LongInt;
Begin
If FInBufPos = FInBufEnd Then Begin
FInBufEnd := fpRecv(FSocketHandle, @FInBuf, TSocketBufferSize, FPRECVOPT);
FInBufPos := 0;
If FInBufEnd <= 0 Then Begin
FInBufEnd := 0;
Result := -1;
Exit;
End;
If FTelnetClient or FTelnetServer Then TelnetInBuffer(FInBuf, FInBufEnd);
End;
If Len > FInBufEnd - FInBufPos Then Len := FInBufEnd - FInBufPos;
Move (FInBuf[FInBufPos], Buf, Len);
Inc (FInBufPos, Len);
Result := Len;
End;
Function TSocketClass.ReadLine (Var Str: String) : LongInt;
Var
Ch : Char;
Res : LongInt;
Begin
Str := '';
Res := 0;
Repeat
If FInBufPos = FInBufEnd Then Res := ReadBuf(Ch, 0);
Ch := FInBuf[FInBufPos];
Inc (FInBufPos);
If (Ch <> #10) And (Ch <> #13) And (FInBufEnd > 0) Then Str := Str + Ch;
Until (Ch = #10) Or (Res < 0) Or (FInBufEnd = 0);
If Res < 0 Then Result := -1 Else Result := Length(Str);
End;
Function TSocketClass.SetBlocking (Block: Boolean): LongInt;
//Var
// Data : DWord;
Begin
If FSocketHandle = -1 Then Begin
Result := FSocketHandle;
Exit;
End;
// Data := Ord(Not Block);
// Result := ioctlSocket(FSocketHandle, FIONBIO, Data);
End;
Function TSocketClass.WaitForData (TimeOut: LongInt) : LongInt;
Var
T : TTimeVal;
rFDSET,
wFDSET,
eFDSET : TFDSet;
Begin
T.tv_sec := 0;
T.tv_usec := TimeOut * 1000;
{$IFDEF UNIX}
fpFD_Zero(rFDSET);
fpFD_Zero(wFDSET);
fpFD_Zero(eFDSET);
fpFD_Set(FSocketHandle, rFDSET);
Result := fpSelect(FSocketHandle + 1, @rFDSET, @wFDSET, @eFDSET, @T);
{$ELSE}
FD_Zero(rFDSET);
FD_Zero(wFDSET);
FD_Zero(eFDSET);
FD_Set(FSocketHandle, rFDSET);
Result := Select(FSocketHandle + 1, @rFDSET, @wFDSET, @eFDSET, @T);
{$ENDIF}
End;
Function ResolveAddress_IPv6(Host:PChar; Remote_Address:PChar):Integer; cdecl; external;
Function TIOSocket.ResolveAddress (Host: String; Remote_Address: pchar):Integer;
Begin
Host := Host + Char(0);
Result := ResolveAddress_IPv6(@Host, Remote_Address);
End;
Function TIOSocket.Connect (Address: String; Port: Word) : Boolean;
Var
Sin6 : TINetSockAddr6;
Sin4 : TINetSockAddr;
Remote_Addr : String;
Family : Integer;
Begin
Result := False;
Family := 0;
Remote_Addr := '';
Family := ResolveAddress (Address, @Remote_Addr);
if Family = 0 Then Begin
if Pos(Address, ':') > 0 then Begin
Family := AF_INET6;
Remote_Addr := Address;
End else Begin
Family := AF_INET;
Remote_Addr := Address;
End;
End;
FSocketHandle := fpSocket(Family, SOCK_STREAM, 0);
If FSocketHandle = -1 Then Begin
Exit;
End;
FPeerName := Address;
if Family = AF_INET6 then Begin
FillChar(Sin6, SizeOf(Sin6), 0);
Sin6.sin6_Family := AF_INET6;
Sin6.sin6_Port := htons(Port);
Sin6.sin6_Addr := StrToNetAddr6(Remote_Addr);
FPeerIP := NetAddrToStr6(Sin6.Sin6_addr);
Result := fpConnect(FSocketHandle, @Sin6, SizeOf(Sin6)) = 0;
End else Begin
FillChar(Sin4, SizeOf(Sin4), 0);
Sin4.sin_Family := AF_INET;
Sin4.sin_Port := htons(Port);
Sin4.sin_Addr := StrToNetAddr(Remote_Addr);
FPeerIP := NetAddrToStr(Sin4.Sin_addr);
Result := fpConnect(FSocketHandle, @Sin4, SizeOf(Sin4)) = 0;
End;
End;
Procedure TIOSocket.WaitInit (NetInterface: String; Port: Word);
Var
SIN : TINetSockAddr6;
Opt : LongInt;
Begin
If NetInterface = '0.0.0.0' Then
NetInterface := '::'
else if NetInterface = '127.0.0.1' then
NetInterface := '::1';
FSocketHandle := fpSocket(AF_INET6, SOCK_STREAM, 0);
Opt := 1;
fpSetSockOpt (FSocketHandle, SOL_SOCKET, SO_REUSEADDR, @Opt, SizeOf(Opt));
SIN.sin6_family := AF_INET6;
SIN.sin6_port := htons(Port);
SIN.sin6_addr := StrToNetAddr6(NetInterface);
fpBind(FSocketHandle, @SIN, SizeOf(SIN));
SetBlocking(True);
End;
Function TIOSocket.WaitConnection (TimeOut: LongInt) : TIOSocket;
Var
Sock : LongInt;
Client : TIOSocket;
PHE : PHostEnt;
SIN : TINetSockAddr6;
Temp : LongInt;
SL : TSockLen;
Code : Integer;
Hold : LongInt;
Begin
Result := NIL;
If TimeOut > 0 Then Begin
SetBlocking(False);
If fpListen(FSocketHandle, 5) = -1 Then Begin
SetBlocking(True);
Exit;
End;
If WaitForData(TimeOut) <= 0 Then Begin
SetBlocking(True);
Exit;
End;
End Else
If fpListen(FSocketHandle, 5) = -1 Then Exit;
Temp := SizeOf(SIN);
Sock := fpAccept(FSocketHandle, @SIN, @Temp);
If Sock = -1 Then Exit;
{
We Need to Determine if this is actually IPv4 Mapped as Six
so that we can display and store the IP 4 Address. This is
necessary to we can make FTP and BINKP work properly by
opening returning ports on IPv4 and not IPv6, which won't work
nor clear firewall with input accept established rule, the norm.
}
FPeerIP := Upcase(NetAddrToStr6(SIN.sin6_addr));
if Length (FPeerIP) > 7 Then
Begin
If Pos('::FFFF:', FPeerIP) = 1 Then // Is IPv4 mapped in 6?
Begin
Delete(FPeerIP, 1, 7); // Strip off ::FFFF:
Delete(FPeerIP, 5, 1); // Remove middle :
val('$' + FPeerIP, Hold, Code); // Convert to IPv4 Addy
FPeerIP := HostAddrToStr(in_addr(Hold));
End;
End;
PHE := GetHostByAddr(@SIN.sin6_addr, 16, AF_INET6);
If Not Assigned(PHE) Then
FPeerName := 'Unknown'
Else
FPeerName := StrPas(PHE^.h_name);
SL := SizeOf(SIN);
fpGetSockName(FSocketHandle, @SIN, @SL);
FHostIP := NetAddrToStr6(SIN.sin6_addr);
Client := TIOSocket.Create;
Client.SocketHandle := Sock;
Client.PeerName := FPeerName;
Client.PeerIP := FPeerIP;
Client.PeerPort := FPort;
Client.HostIP := FHostIP;
Client.FTelnetServer := FTelnetServer;
Client.FTelnetClient := FTelnetClient;
If FTelnetServer Then
Client.WriteStr(#255#251#001#255#251#003); // IAC WILL ECHO
Result := Client;
End;
End.