From 7b11aa8b8aeb278362d78c43b0680bdf41b8612a Mon Sep 17 00:00:00 2001
From: mysticbbs <mysticbbs@gmail.com>
Date: Sun, 24 Mar 2013 11:58:53 -0400
Subject: [PATCH] Import

---
 mdl/m_protocol_binkp.pas | 679 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 679 insertions(+)
 create mode 100644 mdl/m_protocol_binkp.pas

diff --git a/mdl/m_protocol_binkp.pas b/mdl/m_protocol_binkp.pas
new file mode 100644
index 0000000..68d0588
--- /dev/null
+++ b/mdl/m_protocol_binkp.pas
@@ -0,0 +1,679 @@
+Program BinkPoll;
+
+// Need to rewrite.  BuildQueueByNode function PollNode
+// Need to include NETMAIL
+// Need to include point and multi zones (same with tosser)
+
+{$I M_OPS.PAS}
+
+Uses
+  DOS,
+  m_Crypt,
+  m_DateTime,
+  m_FileIO,
+  m_Strings,
+  m_IO_Sockets,
+  m_Protocol_Queue,
+  bbs_Common;
+
+Var
+  bbsConfig : RecConfig;
+
+Const
+  M_NUL  = 0;
+  M_ADR  = 1;
+  M_PWD  = 2;
+  M_FILE = 3;
+  M_OK   = 4;
+  M_EOB  = 5;
+  M_GOT  = 6;
+  M_ERR  = 7;
+  M_BSY  = 8;
+  M_GET  = 9;
+  M_SKIP = 10;
+  M_DATA = 255;
+
+  BinkPMaxBufferSize = 30 * 1024;
+  TempFileTime       = 1363944820;
+
+Const
+  BinkCmdStr : Array[0..10] of String[4] = (
+    'NUL ',
+    'ADR ',
+    'PWD ',
+    'FILE',
+    'OK  ',
+    'EOB ',
+    'GOT ',
+    'ERR ',
+    'BSY ',
+    'GET ',
+    'SKIP'
+  );
+
+Type
+  TBinkAuthState = (
+    SendChallenge,
+    SendWelcome,
+    SendAddress,
+    SendPassword,
+    WaitAddress,
+    WaitPassword,
+    WaitPwdOK,
+    AuthOK,
+    AuthFailed
+  );
+
+  TBinkRxState = (
+    RxNone,
+    RxWaitFile,
+    RxGetData,
+    RxDone
+  );
+
+  TBinkTxState = (
+    TxNone,
+    TxNextFile,
+    TxSendData,
+    TxGetEOF,
+    TxDone
+  );
+
+  TBinkFrameType = (
+    Command,
+    Data
+  );
+
+  TBinkP = Class
+    SetPassword  : String;
+    SetBlockSize : Word;
+    SetTimeOut   : Word;
+
+    Client       : TIOSocket;
+    IsClient     : Boolean;
+    UseMD5       : Boolean;
+    ForceMD5     : Boolean;
+    AuthState    : TBinkAuthState;
+    TimeOut      : LongInt;
+    TxState      : TBinkTxState;
+    RxState      : TBinkRxState;
+    RxFrameType  : TBinkFrameType;
+    RxCommand    : Byte;
+    RxBuffer     : Array[1..BinkPMaxBufferSize] of Char;
+    RxBufSize    : LongInt;
+    HaveHeader   : Boolean;
+    NeedHeader   : Boolean;
+    MD5Challenge : String;
+    FileList     : TProtocolQueue;
+
+    Constructor Create (Var C: TIOSocket; Var FL: TProtocolQueue; IsCli: Boolean; TOV: Word);
+    Destructor  Destroy; Override;
+
+    Function    GetDataStr : String;
+    Procedure   SendFrame     (CmdType: Byte; CmdData: String);
+    Procedure   SendDataFrame (Var Buf; BufSize: Word);
+    Procedure   DoFrameCheck;
+    Function    DoAuthentication : Boolean;
+    Procedure   DoTransfers;
+  End;
+
+Function GetStateStr (S: TBinkAuthState) : String;
+Begin
+  Case S of
+    SendChallenge : Result := 'SendChallenge';
+    SendWelcome   : Result := 'SendWelcome';
+    SendAddress   : Result := 'SendAddress';
+    SendPassword  : Result := 'SendPassword';
+    WaitAddress   : Result := 'WaitAddress';
+    WaitPassword  : Result := 'WaitPassword';
+    WaitPwdOK     : Result := 'WaitPwdOK';
+    AuthOK        : Result := 'AuthOK';
+    AuthFailed    : Result := 'AuthFailed';
+  Else
+    Result := 'Unknown';
+  End;
+End;
+
+Constructor TBinkP.Create (Var C: TIOSocket; Var FL: TProtocolQueue; IsCli: Boolean; TOV: Word);
+Begin
+  Inherited Create;
+
+  SetTimeOut   := TOV;
+  Client       := C;
+  FileList     := FL;
+  IsClient     := IsCli;
+  UseMD5       := False;
+  ForceMD5     := False;
+  RxBufSize    := 0;
+  RxState      := RxNone;
+  TxState      := TxNone;
+  TimeOut      := TimerSet(SetTimeout);
+  NeedHeader   := True;
+  HaveHeader   := False;
+  MD5Challenge := '';
+  AuthState    := SendWelcome;
+
+  If Not IsClient and UseMD5 Then
+    AuthState := SendChallenge;
+End;
+
+Destructor TBinkP.Destroy;
+Begin
+  Inherited Destroy;
+End;
+
+Function TBinkP.GetDataStr : String;
+Var
+  SZ : Byte;
+Begin
+  If RxBufSize > 255 Then
+    SZ := 255
+  Else
+    SZ := RxBufSize;
+
+  Move (RxBuffer[1], Result[1], SZ);
+
+  Result[0] := Char(SZ);
+End;
+
+Procedure TBinkP.SendFrame (CmdType: Byte; CmdData: String);
+Var
+  DataSize : Word;
+Begin
+  DataSize := (Length(CmdData) + 2) OR $8000;
+
+  Client.BufWriteStr(Char(Hi(DataSize)) + Char(Lo(DataSize)) + Char(CmdType) + CmdData + #0);
+  Client.BufFlush;
+
+  WriteLn ('    S ' + BinkCmdStr[CmdType] + ' ' + CmdData);
+  //WriteLn ('Put Command Frame (', BinkCmdStr[CmdType], ') Data: ', CmdData);
+End;
+
+Procedure TBinkP.SendDataFrame (Var Buf; BufSize: Word);
+Var
+  SendData : Array[1.. BinkPMaxBufferSize] of Char Absolute Buf;
+  HiChar   : Char;
+  LoChar   : Char;
+Begin
+  HiChar := Char(Hi(BufSize));
+  LoChar := Char(Lo(BufSize));
+
+  Client.BufFlush;
+
+  Client.WriteBuf (HiChar, 1);
+  Client.WriteBuf (LoChar, 1);
+  Client.WriteBuf (SendData[1], BufSize);
+
+  TimeOut := TimerSet(SetTimeOut);
+
+//  WriteLn ('Put Data Frame (', BufSize, ')');
+End;
+
+Procedure TBinkP.DoFrameCheck;
+Var
+  CharHi : Char;
+  CharLo : Char;
+  InPos  : LongInt;
+Begin
+  If NeedHeader And Not HaveHeader And Client.DataWaiting Then Begin
+    Client.ReadBuf (CharHi, 1);
+    Client.ReadBuf (CharLo, 1);
+
+    RxBufSize := (Word(CharHi) SHL 8) + Word(CharLo);
+
+    If Byte(CharHi) AND $80 = 0 Then Begin
+      RxCommand   := M_DATA;
+      RxFrameType := Data;
+    End Else Begin
+      RxBufSize   := (RxBufSize AND ($8000 - 1)) - 1;
+      RxFrameType := Command;
+
+      Client.ReadBuf (RxCommand, 1);
+    End;
+
+    If RxBufSize > 0 Then
+      For InPos := 1 to RxBufSize Do
+        Client.ReadBuf(RxBuffer[InPos], 1);
+
+    If Client.Connected Then Begin
+      TimeOut    := TimerSet(SetTimeOut);
+      NeedHeader := False;
+      HaveHeader := True;
+    End;
+
+    Case RxFrameType of
+//      Command : If (RxCommand = M_NUL) or (RxCommand = M_ERR) Then
+//                  WriteLn ('    R ', BinkCmdStr[RxCommand], ' ', GetDataStr);
+        Command : WriteLn ('    R ', BinkCmdStr[RxCommand], ' ', GetDataStr);
+//      Data    : WriteLn ('Got Data Frame (Read ', InPos, ' of ', RxBufSize, ')');
+    End;
+  End;
+End;
+
+Function TBinkP.DoAuthentication;
+Var
+  Str   : String;
+  Count : LongInt;
+Begin
+  //WriteLn ('Begin Authentication');
+
+  Repeat
+    DoFrameCheck;
+
+    If Not Client.Connected or (TimerUp(TimeOut)) Then
+      AuthState := AuthFailed
+    Else
+    If HaveHeader and (RxCommand = M_NUL) Then Begin
+      // Eat MNUL and get another header but steal MD5 challenge
+      // and anything else we want to parse from OPTs, etc
+
+      NeedHeader := True;
+      HaveHeader := False;
+
+      Str   := GetDataStr;
+      Count := Pos('MD5-', Str);
+
+      If Count > 0 Then
+        MD5Challenge := Copy(Str, Count + 4, 255);
+    End;
+
+//    WriteLn ('AuthState: ', GetStateStr(AuthState), ', HasHeader: ', HaveHeader, ' Data: ', GetDataStr);
+
+    Case AuthState of
+      SendChallenge : Begin  // Send MD5 digest
+                      End;
+      SendWelcome   : Begin
+                        SendFrame (M_NUL, 'SYS ' + bbsConfig.BBSName);
+                        SendFrame (M_NUL, 'ZYZ ' + bbsConfig.SysopName);
+//                        SendFrame (M_NUL, 'LOC Philadelphia, PA');
+                        SendFrame (M_NUL, 'VER Mystic/1.10 binkp/1.0');
+
+                        If IsClient Then
+                          AuthState := SendAddress
+                        Else
+                          AuthState := WaitAddress;
+                      End;
+
+      SendAddress   : Begin
+                        Str := '';
+
+                        For Count := 1 to 30 Do
+                          If strAddr2Str(bbsConfig.NetAddress[Count]) <> '0:0/0' Then Begin
+                            If Str <> '' Then Str := Str + ' ';
+
+                            Str := Str + strAddr2Str(bbsConfig.NetAddress[Count]);
+
+                            If bbsConfig.NetDomain[Count] <> '' Then
+                              Str := Str + '@' + bbsConfig.NetDomain[Count];
+                          End;
+
+                        SendFrame (M_ADR, Str);
+
+                        AuthState := SendPassword;
+                      End;
+      SendPassword  : If HaveHeader Then Begin // wait for header to see if we support CRAMMD5
+                        If UseMD5 And (MD5Challenge <> '') Then Begin
+                          MD5Challenge := Digest2String(HMAC_MD5(String2Digest(MD5Challenge), SetPassword));
+
+                          SendFrame (M_PWD, 'CRAM-MD5-' + MD5Challenge);
+                        End Else
+                          If ForceMD5 Then Begin
+                            SendFrame (M_ERR, 'Required CRAM-MD5 authentication');
+
+                            AuthState := AuthFailed;
+                          End Else
+                            SendFrame (M_PWD, SetPassword);
+
+                        Client.BufFlush;
+
+                        HaveHeader := False;
+                        NeedHeader := True;
+
+                        If AuthState <> AuthFailed Then
+                          AuthState  := WaitPwdOK;
+                      End;
+      WaitAddress   : Begin
+                        // get address
+                        AuthState := WaitPassword;
+                      End;
+      WaitPassword  : ;
+      WaitPwdOK     : If HaveHeader Then Begin
+                        If RxCommand <> M_OK Then
+                          AuthState := AuthFailed
+                        Else
+                          AuthState := AuthOK;
+                      End;
+    End;
+  Until (AuthState = AuthOK) or (AuthState = AuthFailed);
+
+  Result := AuthState = AuthOK;
+End;
+
+Procedure TBinkP.DoTransfers;
+Var
+  InFile  : File;
+  OutFile : File;
+  OutSize : LongInt;
+  OutBuf  : Array[1..BinkPMaxBufferSize] of Byte;
+  Str     : String;
+  InFN    : String;
+  InSize  : Cardinal;
+  InPos   : Cardinal;
+  InTime  : Cardinal;
+  FSize   : Cardinal;
+Begin
+  //WriteLn ('Begin File Transfers');
+
+  RxState    := RxWaitFile;
+  TxState    := TxNextFile;
+  TimeOut    := TimerSet(SetTimeOut);
+  NeedHeader := True;
+  HaveHeader := False;
+
+  Repeat
+    DoFrameCheck;
+
+    // need to update states to handle getting FILE during an xfer
+    // and what to do if the file frame goes past file size (fail/quit), etc
+
+//    waitms(100);
+//    writeln ('rxstate=', ord(rxstate), '  txstate=', ord(txstate), '  have header ', haveheader, '  need header ', needheader);
+
+    Case RxState of
+      RxWaitFile : If HaveHeader Then Begin
+                     If RxFrameType = Data Then Begin
+                       HaveHeader := False;
+                       NeedHeader := True;
+
+                       Continue;
+                     End;
+
+                     If RxCommand = M_FILE Then Begin
+                       HaveHeader := False;
+                       NeedHeader := True;
+
+                       // translate filename, fix up file times
+
+                       Str    := GetDataStr;
+                       InFN   := strWordGet(1, Str, ' ');
+                       InSize := strS2I(strWordGet(2, Str, ' '));
+                       InTime := strS2I(strWordGet(3, Str, ' '));
+                       InPos  := strS2I(strWordGet(4, Str, ' '));
+
+                       If FileExist(bbsConfig.InBoundPath + InFN) Then Begin
+                         FSize := FileByteSize(bbsConfig.InBoundPath + InFN);
+
+                         // fix timestamp and escape filen
+
+                         If FSize >= InSize Then Begin
+                           SendFrame (M_SKIP, InFN + ' ' + strI2S(FSize) + ' ' + strI2S(InTime));
+
+                           Continue;
+                         End Else Begin
+                           SendFrame (M_GET, InFN + ' ' + strI2S(FSize) + ' ' + strI2S(InTime));
+
+                           InPos := FSize;
+                         End;
+                       End;
+
+                       Assign (InFile, bbsConfig.InBoundPath + InFN);
+                       Reset  (InFile, 1);
+
+                       If IoResult <> 0 Then ReWrite (InFile, 1);
+
+                       Seek (InFile, InPos);
+
+                       RxState := RxGetData;
+                     End Else
+                     If RxCommand = M_EOB Then Begin
+                       NeedHeader := True;
+                       HaveHeader := False;
+                       RxState    := RxDone;
+                     End;
+                   End;
+      RxGetData  : If HaveHeader And (RxFrameType = Data) Then Begin
+                     BlockWrite (InFile, RxBuffer[1], RxBufSize);
+
+                     Inc (InPos, RxBufSize);
+
+                     HaveHeader := False;
+                     NeedHeader := True;
+
+                     If InPos = InSize Then Begin
+                       // fix time, escape filename
+
+                       Close     (InFile);
+                       SendFrame (M_GOT, InFN + ' ' + strI2S(InSize) + ' ' + strI2S(InTime));
+
+                       RxState := RxWaitFile;
+                     End;
+                   End;
+    End;
+
+//    DoFrameCheck;
+
+    Case TxState of
+      TxGetEOF   : Begin
+                     If HaveHeader Then
+                       If RxCommand = M_GOT Then Begin
+                         HaveHeader := False;
+                         NeedHeader := True;
+                         TxState    := TxNextFile;
+                       End;
+                   End;
+      TxNextFile : If FileList.Next Then Begin
+                     Assign (OutFile, FileList.QData[FileList.QPos].FilePath + FileList.QData[FileList.QPos].FileName);
+                     Reset  (OutFile, 1);
+
+                     If IoResult <> 0 Then Continue;
+
+                     // need to escape filename here and fix file time
+                     SendFrame (M_FILE, FileList.QData[FileList.QPos].FileName + ' ' + strI2S(FileList.QData[FileList.QPos].FileSize) + ' ' + strI2S(TempFileTime) + ' 0');
+
+                     TxState := TxSendData;
+                   End Else Begin
+                     SendFrame (M_EOB, '');
+
+                     TxState := TxDone;
+                   End;
+      TxSendData : Begin
+                     If HaveHeader And (RxCommand = M_GET) Then Begin
+                       Str := strWordGet(4, GetDataStr, ' ');
+
+                       Seek (OutFile, strS2I(Str));
+
+                       // fix file time and escape filename
+                       SendFrame (M_FILE, FileList.QData[FileList.QPos].FileName + ' ' + Str + ' ' + strI2S(TempFileTime) + ' 0');
+
+                       HaveHeader := False;
+                       NeedHeader := True;
+
+                       Continue;
+                     End;
+
+                     BlockRead     (OutFile, OutBuf, SizeOf(OutBuf), OutSize);
+                     SendDataFrame (OutBuf, OutSize);
+
+                     If OutSize < SizeOf(OutBuf) Then Begin
+                       Close (OutFile);
+
+                       TxState    := TxGetEOF;
+                       HaveHeader := False;
+                       NeedHeader := True;
+                     End;
+                   End;
+    End;
+  Until ((RxState = RxDone) and (TxState = TxDone)) or (Not Client.Connected) or (TimerUp(TimeOut));
+
+  If Client.Connected Then Client.BufFlush;
+End;
+
+Procedure PollNode (Var Queue: TProtocolQueue; Var EchoNode: RecEchoMailNode);
+Var
+  BinkP  : TBinkP;
+  Client : TIOSocket;
+  Port   : Word;
+Begin
+  Client := TIOSocket.Create;
+
+  Client.FTelnetClient := False;
+  Client.FTelnetServer := False;
+
+  Write ('- Connecting to ', EchoNode.binkHost, ': ');
+
+  Port := strS2I(strWordGet(2, EchoNode.binkHost, ':'));
+
+  If Port = 0 Then Port := 24554;
+
+  If Not Client.Connect (strWordGet(1, EchoNode.binkHost, ':'), Port) Then Begin
+    WriteLn ('UNABLE TO CONNECT');
+
+    Client.Free;
+
+    Exit;
+  End;
+
+  WriteLn ('CONNECTED!');
+
+  BinkP := TBinkP.Create(Client, Queue, True, EchoNode.binkTimeOut * 100);
+
+  BinkP.SetPassword  := EchoNode.binkPass;
+  BinkP.SetBlockSize := EchoNode.binkBlock;
+  BinkP.UseMD5       := EchoNode.binkMD5 > 0;
+  BinkP.ForceMD5     := EchoNode.binkMD5 = 2;
+
+  If BinkP.DoAuthentication Then
+    BinkP.DoTransfers
+  Else
+    WriteLn ('- Unable to authenticate');
+
+  BinkP.Free;
+  Client.Free;
+End;
+
+Function GetFTNFlowName (Dest: RecEchoMailAddr) : String;
+Begin
+  Result := strI2H((Dest.Net SHL 16) OR Dest.Node);
+End;
+
+Procedure ScanOutbound;
+Var
+  DirInfo  : SearchRec;
+  FLOFile  : Text;
+  EchoFile : File of RecEchoMailNode;
+  EchoNode : RecEchoMailNode;
+  Queue    : TProtocolQueue;
+  Str      : String;
+  FN       : String;
+  Path     : String;
+  Matched  : Boolean;
+Begin
+  WriteLn ('Scanning configured Echomail nodes...');
+  WriteLn;
+
+  FindFirst (bbsConfig.OutboundPath + '*.?lo', AnyFile, DirInfo);
+
+  While DosError = 0 Do Begin
+    Write ('- Found ', DirInfo.Name, ' -> Send Type: ');
+
+    Case UpCase(JustFileExt(DirInfo.Name)[1]) of
+      'C' : WriteLn ('Crash');
+      'D' : WriteLn ('Direct');
+      'H' : Begin
+              WriteLn ('Hold - SKIPPING');
+
+              FindNext (DirInfo);
+
+              Continue;
+            End;
+    Else
+      WriteLn ('Normal');
+    End;
+
+    Matched := False;
+
+    Assign (EchoFile, bbsConfig.DataPath + 'echonode.dat');
+    {$I-} Reset (EchoFile); {$I+}
+
+    If IoResult <> 0 Then Begin
+      WriteLn ('- Unable to match .FLO with configured Echomail node');
+
+      FindNext (DirInfo);
+
+      Continue;
+    End;
+
+    While Not Eof(EchoFile) And Not Matched Do Begin
+      Read (EchoFile, EchoNode);
+
+      Matched := (strUpper(JustFileName(DirInfo.Name)) = strUpper(GetFTNFlowName(EchoNode.Address))) and EchoNode.Active and (EchoNode.ProtType = 0);
+    End;
+
+    Close (EchoFile);
+
+    If Not Matched Then Begin
+      WriteLn ('- Unable to match .FLO with configured Echomail node');
+
+      FindNext (DirInfo);
+
+      Continue;
+    End;
+
+    Queue := TProtocolQueue.Create;
+
+    Assign (FLOFile, bbsConfig.OutboundPath + DirInfo.Name);
+    Reset  (FLOFile);
+
+    While Not Eof(FLOFile) Do Begin
+      ReadLn (FLOFile, Str);
+
+      If (Str = '') or (Str[1] = '!') Then Continue;
+
+      Str  := strStripB(Copy(Str, 2, 255), ' ');
+      FN   := JustFile(Str);
+      Path := JustPath(Str);
+
+      Queue.Add (Path, FN);
+    End;
+
+    Close (FLOFile);
+
+    WriteLn('- Queued ', Queue.QSize, ' files (', Queue.QFSize, ' bytes) to ', strAddr2Str(EchoNode.Address));
+
+    If Queue.QSize > 0 Then
+      PollNode(Queue, EchoNode);
+
+    Queue.Free;
+
+    FindNext (DirInfo);
+  End;
+
+  FindClose (DirInfo);
+End;
+
+Var
+  CF : File of RecConfig;
+Begin
+  WriteLn;
+  WriteLn ('BINKPOLL Version ' + mysVersion);
+  WriteLn;
+
+  Assign (CF, '\s7\mystic.dat');
+
+  {$I-} Reset(CF); {$I+}
+
+  If IoResult <> 0 Then Begin
+    WriteLn ('Unable to read MYSTIC.DAT');
+    Halt(1);
+  End;
+
+  Read  (CF, bbsConfig);
+  Close (CF);
+
+  If bbsConfig.DataChanged <> mysDataChanged Then Begin
+    WriteLn ('Mystic VERSION mismatch');
+    Halt(1);
+  End;
+
+  ScanOutbound;
+End.