eric
/
mysticbbs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
mysticbbs/mdl/m_io_sockets.pas

777 lines
20 KiB
ObjectPascal
Raw Permalink Blame History

// ====================================================================
// 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_io_Sockets;
{$link m_resolve_address.o}
{$linklib c}
{$I M_OPS.PAS}
{.$DEFINE TNDEBUG}
Interface
Uses
{$IFDEF OS2}
WinSock,
{$ENDIF}
{$IFDEF WIN32}
Windows,
Winsock2,
{$ENDIF}
{$IFDEF UNIX}
BaseUnix,
cNetDB,
{$ENDIF}
Sockets,
m_DateTime,
m_Strings,
m_io_Base;
Type
TIOSocket = Class(TIOBase)
FSocketHandle : LongInt;
FPort : LongInt;
FPeerName : String;
FPeerIP : String;
FHostIP : String;
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; Override;
Destructor Destroy; Override;
Procedure Disconnect;
Function DataWaiting : Boolean; Override;
Function WriteBuf (Var Buf; Len: LongInt) : LongInt; Override;
Procedure BufFlush; Override;
Procedure BufWriteChar (Ch: Char); Override;
Procedure BufWriteStr (Str: String); Override;
Function WriteLine (Str: String) : LongInt; Override;
Function WriteStr (Str: String) : LongInt; Override;
Function WriteFile (Prefix, FileName: String) : Boolean;
Function WriteBufEscaped (Var Buf: TIOBuffer; Var Len: LongInt) : LongInt;
Procedure TelnetInBuffer (Var Buf: TIOBuffer; Var Len: LongInt);
Function ReadBuf (Var Buf; Len: LongInt) : LongInt; Override;
Function ReadLine (Var Str: String) : LongInt; Override;
Function SetBlocking (Block: Boolean): LongInt;
Function WaitForData (TimeOut: LongInt) : LongInt; Override;
Function Connect (Address: String; Port: Word) : Boolean;
Function ResolveAddress (Host: String; Remote_Address: PChar):Integer;
Procedure WaitInit (NetInterface: String; Port: Word);
Function WaitConnection (TimeOut: LongInt) : TIOSocket;
Function PeekChar (Num: Byte) : Char; Override;
Function ReadChar : Char; Override;
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;
{$IFDEF TNDEBUG}
Function CommandType (C: Char) : String;
Begin
Case C of
TELNET_WILL : Result := 'WILL';
TELNET_WONT : Result := 'WONT';
TELNET_DO : Result := 'DO';
TELNET_DONT : Result := 'DONT';
TELNET_SB : Result := 'SB';
Telnet_IAC : Result := 'IAC';
Telnet_BINARY : Result := 'BINARY';
Telnet_ECHO : Result := 'ECHO';
Telnet_SE : Result := 'SE';
Telnet_TERM : Result := 'TERM';
Telnet_SGA : Result := 'SGA';
Else
Result := 'UNKNOWN';
End;
Result := Result + ' Ord:' + strI2S(Ord(C));
End;
Procedure TNLOG (Str: String);
Var
T : Text;
Begin
Assign (T, 'sockdebug.txt');
{$I-} Append(T); {$I+}
If IoResult <> 0 Then ReWrite(T);
WriteLn(T, Str);
Close(T);
End;
{$ENDIF}
Constructor TIOSocket.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 TIOSocket.Destroy;
Begin
If FDisconnect Then Disconnect;
Inherited Destroy;
End;
Procedure TIOSocket.Disconnect;
Begin
If FSocketHandle <> -1 Then Begin
fpShutdown(FSocketHandle, 2);
CloseSocket(FSocketHandle);
FSocketHandle := -1;
End;
End;
Function TIOSocket.DataWaiting : Boolean;
Begin
Result := (FInBufPos < FInBufEnd) or (WaitForData(1) > 0);
End;
Function TIOSocket.WriteBuf (Var Buf; Len: LongInt) : LongInt;
Begin
Result := fpSend(FSocketHandle, @Buf, Len, FPSENDOPT);
While (Result = -1) and (SocketError = ESOCKEWOULDBLOCK) Do Begin
WaitMS(25);
Result := fpSend(FSocketHandle, @Buf, Len, FPSENDOPT);
End;
End;
Procedure TIOSocket.BufFlush;
Begin
If FOutBufPos > 0 Then Begin
If FTelnetClient or FTelnetServer Then
WriteBufEscaped(FOutBuf, FOutBufPos)
Else
WriteBuf(FOutBuf, FOutBufPos);
FOutBufPos := 0;
End;
End;
Procedure TIOSocket.BufWriteChar (Ch: Char);
Begin
FOutBuf[FOutBufPos] := Ch;
Inc(FOutBufPos);
If FOutBufPos > TIOBufferSize Then
BufFlush;
End;
Procedure TIOSocket.BufWriteStr (Str: String);
Var
Count : LongInt;
Begin
For Count := 1 to Length(Str) Do
BufWriteChar(Str[Count]);
End;
Function TIOSocket.WriteLine (Str: String) : LongInt;
Begin
Result := WriteStr(Str + #13#10);
End;
Function TIOSocket.WriteChar (Ch: Char) : LongInt;
Begin
Result := fpSend(FSocketHandle, @Ch, 1, FPSENDOPT);
End;
Function TIOSocket.WriteStr (Str: String) : LongInt;
Begin
Result := fpSend(FSocketHandle, @Str[1], Length(Str), FPSENDOPT);
End;
Function TIOSocket.WriteFile (Prefix, FileName: String) : Boolean;
Var
T : Text;
S : String;
Begin
Result := False;
FileMode := 66;
Assign (T, FileName);
Reset (T);
If IoResult <> 0 Then Exit;
While Not Eof(T) Do Begin
ReadLn (T, S);
If Prefix <> '' Then
If EOF(T) Then
S := Prefix + ' ' + S
Else
S := Prefix + '- ' + S;
WriteLine(S);
End;
Close (T);
Result := True;
End;
Function TIOSocket.WriteBufEscaped (Var Buf: TIOBuffer; Var Len: LongInt) : LongInt;
Var
Temp : Array[0..TIOBufferSize * 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(25);
Result := fpSend(FSocketHandle, @Temp, TempPos, FPSENDOPT);
End;
End;
Procedure TIOSocket.TelnetInBuffer (Var Buf: TIOBuffer; 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);
{$IFDEF TNDEBUG}
TNLOG ('InBuffer -> Sending response: ' + CommandType(YesNo) + ' ' + CommandType(CmdType));
{$ENDIF}
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);
{$IFDEF TNDEBUG}
TNLOG ('InBuffer -> Sending data response');
{$ENDIF}
End;
Var
Count : LongInt;
TempPos : LongInt;
Temp : TIOBuffer;
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);
{$IFDEF TNDEBUG}
TNLOG ('InBuffer -> Escaped IAC (2x255) to 1 character');
{$ENDIF}
End Else Begin
Inc (FTelnetState);
FTelnetCmd := Buf[Count];
End;
2 : Begin
FTelnetState := 0;
{$IFDEF TNDEBUG}
TNLOG ('InBuffer -> Received telnet command: ' + CommandType(FTelnetCmd) + ' ' + CommandType(Buf[Count]));
{$ENDIF}
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 := False;//(FTelnetCmd = Telnet_DO);
End Else Begin
Case Buf[Count] of
Telnet_ECHO : FTelnetEcho := True;
Telnet_SGA : ;
Telnet_BINARY : ;
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 TIOSocket.ReadChar : Char;
Begin
ReadBuf(Result, 1);
End;
Function TIOSocket.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 TIOSocket.ReadBuf (Var Buf; Len: LongInt) : LongInt;
Begin
If FInBufPos = FInBufEnd Then Begin
FInBufEnd := fpRecv(FSocketHandle, @FInBuf, TIOBufferSize, FPRECVOPT);
FInBufPos := 0;
While (FInBufEnd = -1) and (SocketError = ESOCKEWOULDBLOCK) Do Begin
WaitMS(25);
FInBufEnd := fpRecv(FSocketHandle, @FInBuf, TIOBufferSize, FPRECVOPT);
End;
If FInBufEnd <= 0 Then Begin
FInBufEnd := 0;
Result := -1;
Connected := False;
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 TIOSocket.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;
{$IFDEF UNIX}
Function TIOSocket.SetBlocking (Block: Boolean): LongInt;
Var
Flags : LongInt;
Begin
If FSocketHandle = -1 Then Begin
Result := FSocketHandle;
Exit;
End;
Flags := fpFCntl(FSocketHandle, F_GETFL);
If Block Then
Flags := Flags AND NOT O_NONBLOCK
Else
Flags := Flags OR O_NONBLOCK;
Result := fpFCntl(FSocketHandle, F_SETFL, Flags);
End;
{$ELSE}
Function TIOSocket.SetBlocking (Block: Boolean): LongInt;
Var
Data : DWord;
Begin
If FSocketHandle = -1 Then Begin
Result := FSocketHandle;
Exit;
End;
Data := Ord(Not Block);
Result := ioctlSocket(FSocketHandle, LongInt(FIONBIO), @Data);
End;
{$ENDIF}
Function TIOSocket.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);
{$IFDEF TNDEBUG}
TNLOG('Attempting to bind to interface ' + NetInterface + ' (' + strI2S(SIN.sin6_addr) + ')');
TNLOG('WaitInit Bind');
If fpBind(FSocketHandle, @SIN, SizeOf(SIN)) <> 0 Then
TNLOG('WaitInit Bind Failed')
Else
TNLOG('Bind OK');
{$ELSE}
fpBind(FSocketHandle, @SIN, SizeOf(SIN));
{$ENDIF}
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 (TELNET_IAC + TELNET_WILL + TELNET_ECHO +
TELNET_IAC + TELNET_WILL + TELNET_SGA +
TELNET_IAC + TELNET_DO + TELNET_BINARY);
{$IFDEF TNDEBUG}
If FTelnetServer Then Begin
TNLOG('New server connection');
TNLOG('Sending: IAC WILL ECHO');
TNLOG('Sending: IAC WILL SGA');
TNLOG('Sending: IAC DO BINARY');
End;
{$ENDIF}
Result := Client;
End;
End.
Reference in New Issue View Git Blame Copy Permalink