{*
  CryptedTunnel components module
  Copyright (C) 1999, 2000, 2001 Gregor Ibic (gregor.ibic@intelicom.si)
  Intelicom d.o.o.
  All rights reserved.      This package is a Crypted Tunnel implementation written
  by Gregor Ibic (gregor.ibic@intelicom.si).      This software is provided 'as-is', without any express or
  implied warranty. In no event will the author be held liable
  for any damages arising from the use of this software.      Permission is granted to anyone to use this software for any
  purpose, including commercial applications, and to alter it
  and redistribute it freely, subject to the following
  restrictions:      1. The origin of this software must not be misrepresented,
     you must not claim that you wrote the original software.
     If you use this software in a product, an acknowledgment
     in the product documentation would be appreciated but is
     not required.      2. Altered source versions must be plainly marked as such, and
     must not be misrepresented as being the original software.      3. This notice may not be removed or altered from any source
     distribution.
*}    unit CryptedTunnel;    interface    {$DEFINE COMPRESS}
{$DEFINE BZIP2}
//{$DEFINE LZRW}    uses
  SysUtils, Classes,
  syncobjs,
  IdTunnelMaster, IdTunnelSlave,
  IdTunnelCommon, IdTCPServer,
  IdGlobal, IdComponent,
  MiniCrypt,
{$IFDEF COMPRESS}
{$IFDEF LZRW}
  LZRW1KH,      // LZRW kompresija
{$ENDIF}
{$IFDEF BZIP2}
  Compressors,  // Bzip2 kompresija
{$ENDIF}
{$ENDIF}
  Capi,
  uCAUtils;    type      TTunnelMode = (stmDisconnected,
                 stmConnecting,
                 stmAuthenicating,
                 stmAuthenicated,
                 stmNotAuthenicated);      // Slave thread user defined data
  TSlaveUserData = class(TObject)
  public
    fClientAuthorised: Boolean;
    fAuthorised: Boolean;
    fAddressAuthorised: Boolean;
    fCryptor: TMiniEncryptor;
{$IFDEF COMPRESS}
{$IFDEF LZRW}
    fCompressor: TLZR;
{$ENDIF}
{$IFDEF BZIP2}
    fCompressor: TCompressor;
{$ENDIF}
{$ENDIF}
    fpCompBuffer: PChar;
    fpDeCompBuffer: PChar;
    fpEncrBuffer: PChar;
  end;      TCryptedTunnelMaster = class(TIdTunnelMaster)
  private
    { Private declarations }
    // Properties
    fDSN: String;
    fUser: String;
    fKeyFile: String;
    fPassword: String;
    // Events
    fOnConnect,
    fOnDisconnect,
    fOnTransformRead: TIdServerThreadEvent;
    fOnTransformSend: TSendTrnEvent;
    fOnInterpretMsg: TSendMsgEvent;
    Locker: TCriticalSection;
  protected
    { Protected declarations }
    procedure DoConnect(Thread: TIdPeerThread); override;
    procedure DoDisconnect(Thread: TIdPeerThread); override;
    procedure DoTransformRead(Thread: TIdPeerThread); override;
    procedure DoTransformSend(Thread: TIdPeerThread; var Header: TIdHeader;
var CustomMsg: String); override;
    procedure DoInterpretMsg(Thread: TIdPeerThread; var CustomMsg: String);
override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure GetUserList(var UserList: TStringList);
    procedure KillUser(UserID: Integer);
  published
    { Published declarations }
    property DSN: String read fDSN write fDSN;
    property User: String read fUser write fUser;
    property KeyFile: String read fKeyFile write fKeyFile;
    property Password: String read fPassword write fPassword;
    property OnConnect: TIdServerThreadEvent read FOnConnect write
FOnConnect;
    property OnDisconnect: TIdServerThreadEvent read FOnDisconnect write
FOnDisconnect;
    property OnTransformRead: TIdServerThreadEvent read fOnTransformRead
write fOnTransformRead;
    property OnTransformSend: TSendTrnEvent read fOnTransformSend write
fOnTransformSend;
    property OnInterpretMsg: TSendMsgEvent read fOnInterpretMsg write
fOnInterpretMsg;
  end;          TCryptedTunnelSlave = class(TIdTunnelSlave)
  private
    { Private declarations }
    // Properties
    fCryptor: TMiniEncryptor;
    fAuthorised: Boolean;
    fMode: TTunnelMode;
{$IFDEF COMPRESS}
{$IFDEF LZRW}
    fCompressor: TLZR;
{$ENDIF}
{$IFDEF BZIP2}
    fCompressor: TCompressor;
{$ENDIF}
{$ENDIF}
    fpCompBuffer: PChar;
    fpDeCompBuffer: PChar;
    fpEncrBuffer: PChar;
    fDSN: String;
    fUser: String;
    fKeyFile: String;
    fPassword: String;
    Locker: TCriticalSection;
    // Events
    fOnBeforeTunnelConnect: TSendTrnEventC;
    fOnTransformRead: TTunnelEventC;
    fOnInterpretMsg: TSendMsgEventC;
    fOnTransformSend: TSendTrnEventC;
    fOnStatus: TIdStatusEvent;
//    fOnTunnelDisconnect: TTunnelEvent;
  protected
    { Protected declarations }
    procedure DoBeforeTunnelConnect(var Header: TIdHeader; var CustomMsg:
String); override;
    procedure DoTransformRead(Receiver: TReceiver); override;
    procedure DoInterpretMsg(var CustomMsg: String); override;
    procedure DoTransformSend(var Header: TIdHeader; var CustomMsg: String);
override;
    procedure DoStatus(Sender: TComponent; const sMsg: String); override;
    procedure DoTunnelDisconnect(Thread: TSlaveThread); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property Mode: TTunnelMode read fMode; // write SetMode;
    property DSN: String read fDSN write fDSN;
    property User: String read fUser write fUser;
    property KeyFile: String read fKeyFile write fKeyFile;
    property Password: String read fPassword write fPassword;
    property OnBeforeTunnelConnect: TSendTrnEventC read
fOnBeforeTunnelConnect
                                                  write
fOnBeforeTunnelConnect;
    property OnTransformRead: TTunnelEventC read fOnTransformRead
                                            write fOnTransformRead;
    property OnInterpretMsg: TSendMsgEventC read fOnInterpretMsg write
fOnInterpretMsg;
    property OnTransformSend: TSendTrnEventC read fOnTransformSend write
fOnTransformSend;
    property OnStatus: TIdStatusEvent read FOnStatus write FOnStatus;
  end;    procedure Register;    implementation    procedure Register;
begin
  RegisterComponents('VPN', [TCryptedTunnelSlave]);
  RegisterComponents('VPN', [TCryptedTunnelMaster]);
end;    constructor TCryptedTunnelMaster.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Locker := TCriticalSection.Create;
end;    destructor TCryptedTunnelMaster.Destroy;
begin
  Locker.Free;
  inherited Destroy;
end;    procedure TCryptedTunnelMaster.GetUserList(var UserList: TStringList);
var
  i: integer;
  list: TList;
  Thread: TIdPeerThread;
  tmpSlaveData: TSlaveUserData;
  s, t: String;
begin
  List := Threads.LockList;
  try
    for i := Pred(list.Count) DownTo 0 do begin
      s := '';
      Thread := TIdPeerThread(List[i]);
      s := 'A:'   Thread.Connection.Binding.PeerIP   ';';
      s := s   'P:'   IntToStr(Thread.Connection.Binding.PeerPort)   ';';
      tmpSlaveData := TSlaveUserData(TSlaveData(Thread.Data).UserData);
      if tmpSlaveData.fAuthorised then begin
        t := tmpSlaveData.fCryptor.m_checkUserID;
        s := s   'U:'   t   ';';
      end
      else begin
      end;
      s := s   'I:'   IntToStr(Thread.ThreadID)   ';';
      UserList.Add(s);
    end;
  finally
    Threads.UnlockList;
  end;
end;    procedure TCryptedTunnelMaster.KillUser(UserID: Integer);
var
  i: integer;
  list: TList;
  Thread: TIdPeerThread;
begin
  List := Threads.LockList;
  try
    for i := Pred(list.Count) DownTo 0 do begin
      Thread := TIdPeerThread(List[i]);
      if Thread.ThreadID = UserID then begin
        Thread.Connection.Disconnect;
      end;
    end;
  finally
    Threads.UnlockList;
  end;
end;    procedure TCryptedTunnelMaster.DoConnect(Thread: TIdPeerThread);
var
  pDSN,
  pUser,
  pKeyFile,
  pPassword: array[0..200] of Char;
begin      inherited;      StrPLCopy(pDSN, fDSN, 200);
  StrPLCopy(pUser, fUser, 200);
  StrPLCopy(pKeyFile, fKeyFile, 200);
  StrPLCopy(pPassword, fPassword, 200);      TSlaveData(Thread.Data).UserData := TSlaveUserData.Create;
  with TSlaveUserData(TSlaveData(Thread.Data).UserData) do begin
    fClientAuthorised := True;
.
.
.
.            fAddressAuthorised := True;
  end;    {*
  if Assigned(fOnBeforeTunnelConnect) then
    fOnBeforeTunnelConnect(Header, CustomMsg);
*}    end;    procedure TCryptedTunnelMaster.DoDisconnect(Thread: TIdPeerThread);
begin
  with TSlaveUserData(TSlaveData(Thread.Data).UserData) do begin
.
.
.
..
.        FreeMem(fpCompBuffer, BUFFERLEN);
    FreeMem(fpDeCompBuffer, BUFFERLEN);
    FreeMem(fpEncrBuffer, BUFFERLEN);
  end;
{*
  if Assigned(OnDisconnect) then begin
    OnDisconnect(Thread);
  end;
*}
//  Locker.Free;
  inherited;
end;    procedure TCryptedTunnelMaster.DoTransformRead(Thread: TIdPeerThread);
var
  UserData: TSlaveUserData;
  User: TSlaveData;
  lenDeComp: Integer;
  lenEncr: Integer;
  status: Integer;
begin
//  inherited;      Locker.Enter;
  try        User     := TSlaveData(Thread.Data);
    UserData := TSlaveUserData(TSlaveData(Thread.Data).UserData);        // kompresija   enkripcija
    if User.Receiver.Header.MsgType = tmCustom then begin
.
.
.
.
.        end
    else begin
      try
        status := UserData.fCryptor.Decrypt(PCByte(User.Receiver.Msg),
User.Receiver.MsgLen);
        if status < 0 then begin
          LogEvent('Error in decrypt: '   IntToStr(status));
          User.Receiver.Header.MsgType := tmError; // signal the error
        end;
.
.
.
.              except
        LogEvent('Except during read');
        User.Receiver.Header.MsgType := tmError; // signal the error
      end;
    end;      finally
    Locker.Leave;
  end;    {*
  if Assigned(fOnTransformRead) then
    fOnTransformRead(Thread);
*}
end;    procedure TCryptedTunnelMaster.DoTransformSend(Thread: TIdPeerThread; var
Header: TIdHeader; var CustomMsg: String);
var
  UserData: TSlaveUserData;
  lenComp: Integer;
  lenEncr: Integer;
  status: Integer;
begin
//  inherited;      Locker.Enter;
  try
    UserData := TSlaveUserData(TSlaveData(Thread.Data).UserData);        if Header.MsgType = tmCustom then begin
.
.
.        end
    else begin
      try
        lenComp :=
UserData.fCompressor.Compression(BufferPtr(PChar(@CustomMsg[1])),
BufferPtr(UserData.fpCompBuffer), Length(CustomMsg));
.
.
.
      except
.
.          end;    .
.      finally
    Locker.Leave;
  end;    {*
  if Assigned(fOnTransformSend) then
    fOnTransformSend(Thread, Header, CustomMsg);
*}
end;    procedure TCryptedTunnelMaster.DoInterpretMsg(Thread: TIdPeerThread; var
CustomMsg: String);
var
  UserData: TSlaveUserData;
  User: TSlaveData;
  statusS: Integer;
  lenEncr: Integer;
begin
//  inherited;      Locker.Enter;
  try
    User      := TSlaveData(Thread.Data);
    UserData  := TSlaveUserData(TSlaveData(Thread.Data).UserData);
    CustomMsg := '';        if not UserData.fAuthorised then begin
      statusS := UserData.fCryptor.SessionStage(PCBYTE(user.receiver.Msg),
user.receiver.MsgLen, 111);
.
.    .          end;
    end;
  finally
    Locker.Leave;
  end;    {*
  if Assigned(fOnInterpretMsg) then
    fOnInterpretMsg(Thread, CustomMsg);
*}
end;        /////////////////////////////////////////////////////////////////////    constructor TCryptedTunnelSlave.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fMode := stmDisconnected;
  fAuthorised := False;
  fbAcceptConnections := False;
  Locker := TCriticalSection.Create;
{$IFDEF COMPRESS}
{$IFDEF LZRW}
  fCompressor := TLZR.Create;
{$ENDIF}
{$IFDEF BZIP2}
  fCompressor := TCompressor.Create;
{$ENDIF}
{$ENDIF}
  GetMem(fpCompBuffer, BUFFERLEN);
  GetMem(fpDeCompBuffer, BUFFERLEN);
  GetMem(fpEncrBuffer, BUFFERLEN);
end;    destructor TCryptedTunnelSlave.Destroy;
begin
{$IFDEF COMPRESS}
  fCompressor.Destroy;
{$ENDIF}
  FreeMem(fpCompBuffer, BUFFERLEN);
  FreeMem(fpDeCompBuffer, BUFFERLEN);
  FreeMem(fpEncrBuffer, BUFFERLEN);
  Locker.Free;
  inherited Destroy;
end;    procedure TCryptedTunnelSlave.DoBeforeTunnelConnect(var Header: TIdHeader;
var CustomMsg: String);
var
  lenEncr: Integer;
  pDSN,
  pUser,
  pKeyFile,
  pPassword: array[0..200] of Char;
begin
  Locker.Enter;
  try
    fMode := stmConnecting;
.
.
.
  finally
    Locker.Leave;
  end;    {*
  inherited;
  if Assigned(fOnBeforeTunnelConnect) then
    fOnBeforeTunnelConnect(Header, CustomMsg);
*}
end;    procedure TCryptedTunnelSlave.DoTransformRead(Receiver: TReceiver);
var
  lenDeComp,
  statusC,
  lenEncr: Integer;
  //ratio: Real;
begin      Locker.Enter;
  try
    statusC := 0;        if Receiver.Header.MsgType = tmCustom then begin
.
.
    end
    else begin
      try
.
.
    end;      finally
    Locker.Leave;
  end;    {*
  inherited;      if Assigned(fOnTransformRead) then
    fOnTransformRead(Receiver);
*}
end;    procedure TCryptedTunnelSlave.DoInterpretMsg(var CustomMsg: String);
var
  statusC, lenEncr: Integer;
  //r: Real;
begin
  Locker.Enter;
  try
    if not fAuthorised then begin
      try
.
.      finally
    Locker.Leave;
  end;    {*
  inherited;
  if Assigned(fOnInterpretMsg) then
    fOnInterpretMsg(CustomMsg);
*}
end;    procedure TCryptedTunnelSlave.DoTransformSend(var Header: TIdHeader; var
CustomMsg: String);
var
  lenComp: Integer;
  lenEncr: Integer;
  status: Integer;
begin      Locker.Enter;
  try        if Header.MsgType = tmCustom then begin
.
.
.      finally
    Locker.Leave;
  end;      inherited;
{*  if Assigned(fOnTransformSend) then
    fOnTransformSend(Header, CustomMsg);
*}
end;    procedure TCryptedTunnelSlave.DoStatus(Sender: TComponent; const sMsg:
String);
begin
//  inherited;
//  status is already trigered from the inherited procedure
  if Assigned(OnStatus) then
    OnStatus(self, hsText, sMsg);
//
end;    procedure TCryptedTunnelSlave.DoTunnelDisconnect(Thread: TSlaveThread);
begin      inherited;
  try
.
.
.
  finally
  end;
end;    end.