unit CryptDBSquare;

interface

uses
  SysUtils;

type
  LikeStr = string[20];
  TTabl = array[1..16,1..16] of byte;
  TArray = array[0..255] of byte;
  TBuffer = array[0..4095] of byte;
  TKey =
    record
      User, Desc: LikeStr;
      KeyA, KeyB: TTabl
    end;
  IPos =
    record
      horpos, verpos: 1..16
    end;
  KeyFile = file of TKey;

function Crypt(InputStr: string; Key: TKey): string;
procedure CryptFile(InputFileName, OutputFileName: string; Key: TKey);
function GetDescFromKey(Key: TKey): LikeStr;
function GetIPos(Tabl: TTabl; It: byte): IPos;
function GetUserNameFromKey(Key: TKey): LikeStr;
function GenerateKey(UserName, Desc: LikeStr): TKey;
procedure LoadKey(var Key: TKey; FileName: string);
procedure SaveKey(Key: TKey; FileName: string);
function UnCrypt(InputStr: string; Key: TKey): string;
procedure UnCryptFile(InputFileName, OutputFileName: string; Key: TKey);

implementation

const
  K1 = 64;
  K2 = 28;
  K3 = 16;
  K4 = 13;

function GetIPos(Tabl: TTabl; It: byte): IPos;
var
  i,k: byte;
begin
  for i:=1 to 16 do
    for k:=1 to 16 do
      if Tabl[i,k]=It then
        begin
          result.horpos := i;
          result.verpos := k;
          break;
        end;
end;

procedure FillArray(var A: Tarray);
var
  i, s, r: integer;
begin
  randomize;
  for i := 0 to 31 do
    A[i]:=i;
  for i := 32 to 255 do A[i] := i;
    for i := 255 downto 32 do
      begin
        r := Random(i-32)+32;
        S := A[r]; A[r] := A[i]; A[i] := s;
      end;
end;

function GenerateKey(UserName, Desc: LikeStr): TKey;
var
  TempKey: TKey;
  BufTab: TArray;
  a,i,k: byte;
begin
  FillArray(BufTab);
  for i:=1 to 16 do
    for k:=1 to 16 do
      result.KeyA[i,k]:=BufTab[(16*(i-1))+k-1];
  FillArray(BufTab);
  for i:=1 to 16 do
    for k:=1 to 16 do
      result.KeyB[i,k]:=BufTab[(16*(i-1))+k-1];
  TempKey := result;
  result.User := Crypt(UserName, TempKey);
  result.Desc := Crypt(Desc, TempKey);
end;

function GetUserNameFromKey(Key: TKey): LikeStr;
begin
  result := UnCrypt(Key.User, Key);
end;

function GetDescFromKey(Key: TKey): LikeStr;
begin
  result := UnCrypt(Key.Desc, Key);
end;

function CryptSimText(InputStr: string; Key: TKey): string;
var
  i: integer;
  Temp: string;
  p1,p2:IPos;
begin
  result:='';
  Temp:=InputStr;
    while Temp<>'' do
      begin
        p1:=GetIPos(Key.KeyA,ord(Temp[1]));
        p2:=GetIPos(Key.KeyB,ord(Temp[2]));
        if p1.horpos = p2.horpos then
          begin
            result:=result+chr(Key.KeyB[p1.horpos,p1.verpos]);
            result:=result+chr(Key.KeyA[p2.horpos,p2.verpos]);
            delete(temp,1,2);
          end
        else
          begin
            result:=result+chr(Key.KeyB[p1.horpos,p2.verpos]);
            result:=result+chr(Key.KeyA[p2.horpos,p1.verpos]);
            delete(temp,1,2);
          end;
      end;
end;

function Crypt(InputStr: string; Key: TKey): string;
var
  a: string;
begin
  if not odd(length(InputStr)) then
    result:=CryptSimText(InputStr,Key)
  else
    begin
      a:=copy(InputStr,length(InputStr),1);
      delete(InputStr,length(InputStr),1);
      result:=CryptSimText(InputStr,Key)+a;
    end;
end;

function CryptBlockOfBytes(Buf: TBuffer; Key: TKey): TBuffer;
var
  i: integer;
  Temp: TBuffer;
  p1,p2:IPos;
begin
  Temp:=Buf;
  for i:=0 to SizeOf(Temp) - 1 do if (i)mod(2)=0 then
    begin
      p1:=GetIPos(Key.KeyA,Temp[i]);
      p2:=GetIPos(Key.KeyB,Temp[i+1]);
      if p1.horpos = p2.horpos then
        begin
          result[i]:=Key.KeyB[p1.horpos,p1.verpos];
          result[i+1]:=Key.KeyA[p2.horpos,p2.verpos];
        end
      else
        begin
          result[i]:=Key.KeyB[p1.horpos,p2.verpos];
          result[i+1]:=Key.KeyA[p2.horpos,p1.verpos];
        end;
    end;
end;


procedure CryptFile(InputFileName, OutputFileName: string; Key: TKey);
var
  FromF, ToF: file;
  NumRead, NumWritten, i: Integer;
  Buf: TBuffer;
  TempStr: string;
begin
  AssignFile(FromF, InputFileName);
  Reset(FromF, 1);
  AssignFile(ToF, OutputFileName);
  Rewrite(ToF, 1);
    repeat
      BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
      Buf := CryptBlockOfBytes(Buf, Key);
      BlockWrite(ToF, Buf, NumRead, NumWritten);
    until
      (NumRead = 0) or (NumWritten <> NumRead);
  CloseFile(FromF);
  CloseFile(ToF);
end;

function UnCryptSimText(InputStr: string; Key: TKey): string;
var
  i: integer;
  Temp: string;
  p1,p2:IPos;
begin
  result:='';
  Temp:=InputStr;
    while Temp<>'' do
      begin
        p1:=GetIPos(Key.KeyB,ord(Temp[1]));
        p2:=GetIPos(Key.KeyA,ord(Temp[2]));
        if p1.horpos = p2.horpos then
          begin
            result:=result+chr(Key.KeyA[p1.horpos,p1.verpos]);
            result:=result+chr(Key.KeyB[p2.horpos,p2.verpos]);
            delete(temp,1,2);
          end
        else
          begin
            result:=result+chr(Key.KeyA[p1.horpos,p2.verpos]);
            result:=result+chr(Key.KeyB[p2.horpos,p1.verpos]);
            delete(temp,1,2);
          end;
      end;
end;

function UnCrypt(InputStr: string; Key: TKey): string;
var
  a: string;
begin
  if not odd(length(InputStr)) then
    result:=UnCryptSimText(InputStr,Key)
  else
    begin
      a:=copy(InputStr,length(InputStr),1);
      delete(InputStr,length(InputStr),1);
      result:=UnCryptSimText(InputStr,Key)+a;
    end;
end;

function UnCryptBlockOfBytes(Buf: TBuffer; Key: TKey): TBuffer;
var
  i: integer;
  Temp: TBuffer;
  p1,p2:IPos;
begin
  Temp:=Buf;
  for i:=0 to SizeOf(Temp) - 1 do if (i)mod(2)=0 then
    begin
      p1:=GetIPos(Key.KeyB,Temp[i]);
      p2:=GetIPos(Key.KeyA,Temp[i+1]);
      if p1.horpos = p2.horpos then
        begin
          result[i]:=Key.KeyA[p1.horpos,p1.verpos];
          result[i+1]:=Key.KeyB[p2.horpos,p2.verpos];
        end
      else
        begin
          result[i]:=Key.KeyA[p1.horpos,p2.verpos];
          result[i+1]:=Key.KeyB[p2.horpos,p1.verpos];
        end;
    end;
end;

procedure UnCryptFile(InputFileName, OutputFileName: string; Key: TKey);
var
  FromF, ToF: file;
  NumRead, NumWritten, i: Integer;
  Buf: TBuffer;
  TempStr: string;
begin
  AssignFile(FromF, InputFileName);
  Reset(FromF, 1);
  AssignFile(ToF, OutputFileName);
  Rewrite(ToF, 1);
    repeat
      BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
      Buf := UnCryptBlockOfBytes(Buf, Key);
      BlockWrite(ToF, Buf, NumRead, NumWritten);
    until
      (NumRead = 0) or (NumWritten <> NumRead);
  CloseFile(FromF);
  CloseFile(ToF);
end;

procedure SaveKey(Key: TKey; FileName: string);
var
  KF: KeyFile;
begin
  assignfile(KF,FileName);
  rewrite(KF);
  write(KF,Key);
  closefile(KF);
end;

procedure LoadKey(var Key: TKey; FileName: string);
var
  KF: KeyFile;
begin
  assignfile(KF,FileName);
  reset(KF);
  read(KF,Key);
  closefile(KF);
end;

end.

unit SMTP;

{*******************************************************}
{            SMTP - Модуль для Delphi+KOL               }
{ Version:   1.0                                        }
{ E-Mail:    joker-jar@kbrdhook.com                     }
{ Created:   October  08, 2006                          }
{ Legal:     Copyright (c) 2006, Joker-jar              }
{*******************************************************}
{ ТИПЫ:                                                 }
{   TLetter - струтура письма                           }
{             NeedAuth - нужна ли аутентификация        }
{             mHost - адрес сервера SMTP                }
{             uName, uPass - имя пользователя, пароль   }
{             mFromName, mFrom - имя, адрес отправителя }
{             mToName, mTo - имя, адрес получателя      }
{             Subject - тема письма                     }
{             mBody - тело письма                       }
{*******************************************************}
{ КОНСТАНТЫ:                                            }
{   TimeOut - Максимальное время ожидания ответа от     }
{             сервера                                   }
{                                                       }
{   Bound - Разделитель блоков в теле письма            }
{                                                       }
{   MIME - Заголовок MIME                               }
{*******************************************************}
{ ПРОЦЕДУРЫ:                                            }
{   OpenMIME - Устанавливает в начало тела письма       }
{              MIME заголовок. Вызывается один раз      }
{              при заполнении тела письма.              }
{                                                       }
{   CloseMIME - Устанавливает в конец тела письма       }
{               метку об окончании MIME. Вызывается     }
{               один раз по завершению заполнения       }
{               тела письма.                            }
{                                                       }
{   AddHTMLBlockToBody - Добавляет HTML блок к телу     }
{                        письма. Прежде чем             }
{                        использовать, убедитесь,       }
{                        что инициализирован MIME       }
{                        командой OpenMIME в начале     }
{                        тела письма.                   }
{                                                       }
{   AttachFileToBody - Прикрепляет произвольный файл    }
{                      к телу письма. Прежде чем        }
{                      использовать, убедитесь, что     }
{                      инициализирован MIME командой    }
{                      OpenMIME в начале тела письма.   }
{                                                       }
{                                                       }
{   SMTPConnectAndSendMail - Процедура отправляет       }
{                            письмо и выводит ответы    }
{                            сервера в Memo,            }
{                            переданное как OutServAns  }
{                            (Можно в качестве          }
{                            OutServAns передать nil)   }
{*******************************************************}

interface

uses
  KOL, Windows, Winsock;

type
  Tarray = array of string;
  TLetter =
    record
      NeedAuth: boolean;
      mHost, uName, uPass, mFrom,
      mTo, mFromName, mToName, Subject: string;
      mBody: Tarray;
    end;

const
  TimeOut = 1000;
  Bound = 'ENDBLOCK';
  MIME = 'MIME-Version:1.0';

procedure OpenMIME(var mBody: TArray);
procedure CloseMIME(var mBody: TArray);
procedure AddHTMLBlockToBody(var mBody: TArray; HTMLText: string);
procedure AttachFileToBody(var mBody: TArray; Filename: string);
procedure SMTPConnectAndSendMail(Letter: TLetter; OutServAns: Pcontrol);

implementation

type
  TAByte = array [0..maxInt-1] of byte;
  TPAByte = ^TAByte;

const
  CtrlF = #13#10;

var
  WSA:TWSAData;
  MailSocket:TSocket;
  SMTPServer:TSockAddr;

function MyInc(var i:integer): integer;
begin
  inc(i);
  result := i;
end;

function GetComputerNetName: string;
var 
  buffer: array[0..255] of char;
  size: dword;
begin 
  size := 256;
  if GetComputerName(buffer, size) then
    Result := buffer
  else
    Result := ''
end;

function B64Encode(data:string) : string; overload;
const
  b64 : array [0..63] of char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
var
  ic,len : integer;
  pi, po : TPAByte;
  c1 : dword;
begin
  len:=length(data);
  if len > 0 then
    begin
      SetLength(result, ((len + 2) div 3) * 4);
      pi := pointer(data);
      po := pointer(result);
      for ic := 1 to len div 3 do
        begin
          c1 := pi^[0] shl 16 + pi^[1] shl 8 + pi^[2];
          po^[0] := byte(b64[(c1 shr 18) and $3f]);
          po^[1] := byte(b64[(c1 shr 12) and $3f]);
          po^[2] := byte(b64[(c1 shr 6) and $3f]);
          po^[3] := byte(b64[(c1 ) and $3f]);
          inc(dword(po), 4);
          inc(dword(pi), 3);
        end;
      case len mod 3 of
        1:
          begin
            c1 := pi^[0] shl 16;
            po^[0] := byte(b64[(c1 shr 18) and $3f]);
            po^[1] := byte(b64[(c1 shr 12) and $3f]);
            po^[2] := byte('=');
            po^[3] := byte('=');
          end;
        2 :
          begin
            c1 := pi^[0] shl 16 + pi^[1] shl 8;
            po^[0] := byte(b64[(c1 shr 18) and $3f]);
            po^[1] := byte(b64[(c1 shr 12) and $3f]);
            po^[2] := byte(b64[(c1 shr 6) and $3f]);
            po^[3] := byte('=');
          end;
      end;
    end
  else
    result := '';
end;

function LookupName(host: string): TInAddr;
var
  HostEnt: PHostEnt;
  InAddr: TInAddr;
begin
  HostEnt := gethostbyname(PChar(host));
  FillChar(InAddr, SizeOf(InAddr), 0);
  if HostEnt <> nil then
    begin
      with InAddr, HostEnt^ do
        begin
          S_un_b.s_b1 := h_addr^[0];
          S_un_b.s_b2 := h_addr^[1];
          S_un_b.s_b3 := h_addr^[2];
          S_un_b.s_b4 := h_addr^[3];
        end;
    end;
  Result := InAddr;
end;

function SMTPRecvReply(MailSocket:TSocket):string;
var
  t: integer;
  Buffer:Array[0..255] of char;
begin
  ZeroMemory(@Buffer,256);
  t:=GetTickCount;
    repeat
    until
      (Recv(MailSocket,Buffer,SizeOf(Buffer),0)>0)or(GetTickCount - t >= TimeOut);
  result := buffer+CTRLF;
end;   

procedure SMTPSendString(MailSocket:TSocket;Str:string);
var
  Buffer:Array[0..255] of char;
begin
  StrPCopy(Buffer,Str);
  Send(MailSocket,Buffer,length(Str),0);
end;

procedure SendComandAndWaitAnswer(MailSocket: TSocket;OutServAns: Pcontrol;Str: string);
begin
  SMTPSendString(MailSocket,Str);
  if Assigned(OutServAns) then
    begin
      OutServAns.Add(SMTPRecvReply(MailSocket));
      OutServAns.Perform($0115, SB_BOTTOM,0);
    end;
end;

procedure AddstringToBody(var mBody: Tarray; str: String);
var
  m: integer;
begin
  m := high(mBody);
  setlength(mBody,m+2);
  mBody[m+1]:=str;
end;

procedure OpenMIME(var mBody: TArray);
var
  i: integer;
begin
  i:=0;
  setlength(mBody, 3);
  mBody[i] := MIME;
  mBody[myinc(i)] := 'Content-Type: multipart/mixed; boundary="'+Bound+'"';
  mBody[myinc(i)] := '--'+Bound;
end;

procedure CloseMIME(var mBody: TArray);
begin
  mBody[High(mBody)] := mBody[High(mBody)]+'--';
end;


procedure AddHTMLBlockToBody(var mBody: TArray; HTMLText: string);
begin
  AddstringToBody(mBody,'Content-Type: text/html; charset=Windows-1251');
  AddstringToBody(mBody,'Content-Transfer-Encoding: 8bit');
  AddstringToBody(mBody, '');
  AddstringToBody(mBody, HTMLtext);
  AddstringToBody(mBody,'--'+Bound);
end;

procedure AttachFileToBody(var mBody: TArray; Filename: string);
var
  k: integer;
  c: byte;
  tempStr: string;
  F: file of byte;
begin
  if (not fileexists(filename))or(filesize(filename)=0) then
    exit;
  AddstringToBody(mBody,'Content-Type: application/octet-stream; name="'+ExtractFileName(FileName)+'"');
  AddstringToBody(mBody,'Content-Disposition: attachment; filename="'+ExtractFileName(FileName)+'"');
  AddstringToBody(mBody,'Content-Transfer-Encoding: base64');
  AddstringToBody(mBody,'');
  k:=0;
  AssignFile(F, FileName);
  Reset(F);
    repeat
      inc(k);
      Read(F, c);
      tempstr:=tempstr+chr(c);
      if k mod 38 = 0 then
        begin
          AddstringToBody(mBody, b64encode(tempstr));
          tempstr:='';
        end;
    until
      (eof(F));
  CloseFile(F);
  AddstringToBody(mBody, b64encode(tempstr));
  AddstringToBody(mBody,'--'+Bound);
end;

procedure SMTPConnectAndSendMail(Letter: TLetter; OutServAns: Pcontrol);
var
  i: integer;
begin
  WSAStartup(MAKEWORD(1,0),WSA);
  MailSocket:=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
  ZeroMemory(@SMTPServer,SizeOf(SMTPServer));
  SMTPServer.sin_family:=AF_INET;
  SMTPServer.sin_port:=htons(25);
  SMTPServer.sin_addr:=LookupName(Letter.mHost);
  if Connect(MailSocket,SMTPServer,SizeOf(SMTPServer))=0 then
    begin
      SendComandAndWaitAnswer(mailsocket, OutServAns, 'HELO '+ GetComputerNetName + CTRLF);
      if Letter.NeedAuth then
        SendComandAndWaitAnswer(mailsocket, OutServAns, 'AUTH LOGIN ' + CTRLF + b64encode(Letter.uName) + CTRLF + b64encode(Letter.uPass) + CTRLF);
      SendComandAndWaitAnswer(mailsocket, OutServAns, 'MAIL FROM:' + Letter.mFrom + CTRLF + 'RCPT TO:' + Letter.mTo + CTRLF);
      SendComandAndWaitAnswer(mailsocket, OutServAns, 'DATA' + CTRLF + 'From: "' + Letter.mFromName + '" <' + Letter.mFrom + '>' + CTRLF + 'To: "' + Letter.mToName + '" <' + Letter.mTo + '>' + CTRLF + 'Subject: ' + Letter.Subject + CTRLF);
      for i:=0 to high(Letter.mBody) do
        SMTPSendString(mailsocket,Letter.mBody[i]+CTRLF);
      SendComandAndWaitAnswer(mailsocket, OutServAns, CTRLF+'.'+CTRLF+CTRLF+'QUIT');
    end
  else
    if Assigned(OutServAns) then
      OutServAns.Add('Unable to connect to '+Letter.mHost);
  CloseSocket(MailSocket);
  WSACleanup;
end;

end.