ProtectionUnit.pas

unit ProtectionUnit;

{$mode objfpc}{$H+}

interface


uses
  Classes, SysUtils, Windows, Registry, Dialogs, md5, rc6, SSXMLUnit, Controls,
  Types, LResources, LCLIntf, InterfaceBase, FileUtil,
  LCLType, LCLProc, Forms, Themes,
  GraphType, Graphics, Buttons, ButtonPanel, StdCtrls, ExtCtrls;

const
  hKeyHandle:HKEY = HKEY_CURRENT_USER;

var
  CryptoKey1,CryptoKey2,CryptoKey3,CryptoKey4:String;
  ProgramRegKey,SeqProgramRegKey,InstallParamValue:String;
  SecretDate,SecretDiskSerial:String;

  Serial:String;
  SerialName:String;
  SerialId:String;
  SerialDate:String;



procedure SaveConfig;
procedure LoadConfig;
//function CheckProgramInstallation:boolean;
function GetHardDiskSerial(const DriveLetter: Char): string;
function GetBiosNumber: string;

//procedure MakeRegistrationSerial;
//procedure MakeRegistration;

function EncryptString(src,key:String):String;

implementation

uses
   ConstantsUnit, SSNoiseUnit, MainFormUnit;

function ShowInputDialog(const InputCaption,InputPrompt:String;MaskInput:Boolean;var Value:String):Boolean;

  function ActiveMonitor: TMonitor; inline;
  begin
    if Screen.ActiveCustomForm <> nil then
      Result := Screen.ActiveCustomForm.Monitor
    else
    if Application.MainForm <> nil then
      Result := Application.MainForm.Monitor
    else
      Result := Screen.PrimaryMonitor;
  end;

var
  Form: TForm;
  Prompt: TLabel;
  Edit: TEdit;
  MinEditWidth: integer;
  AMonitor: TMonitor;
begin
  Result := False;
  Form := TForm.CreateNew(nil, 0);
  with Form do
  begin
    BorderStyle := bsDialog;
    Caption := InputCaption;
    Prompt := TLabel.Create(Form);
    with Prompt do
    begin
      Parent := Form;
      Caption := InputPrompt;
      Align := alTop;
      AutoSize := True;
    end;
    Position := poScreenCenter;
    Edit := TEdit.Create(Form);
    with Edit do
    begin
      Parent := Form;
      Align := alTop;
      BorderSpacing.Top := 3;
      AMonitor := ActiveMonitor;
      // check that edit is smaller than our monitor, it must be smaller at least
      // by 6 * 2 pixels (spacing from window borders) + window border
      MinEditWidth := Min(AMonitor.Width - 20, Max(260, AMonitor.Width div 4));
      Constraints.MinWidth := MinEditWidth;
      Text := Value;
      TabStop := True;
      if MaskInput then
      begin
        EchoMode := emPassword;
        PasswordChar := '*';
      end else
      begin
        EchoMode := emNormal;
        PasswordChar := #0;
      end;
      TabOrder := 0;
    end;

    with TButtonPanel.Create(Form) do
    begin
      Parent := Form;
      ShowBevel := False;
      ShowButtons := [pbOK, pbCancel];
      Align := alTop;
    end;

    ChildSizing.TopBottomSpacing := 6;
    ChildSizing.LeftRightSpacing := 6;
    AutoSize := True;

    // upon show, the edit control will be focused for editing, because it's
    // the first in the tab order
    if ShowModal = mrOk then
    begin
      Value := Edit.Text;
      Result := True;
    end;
    Form.Free;
  end;
end;

function EncodeBase64(const inStr: string): string;

  function Encode_Byte(b: Byte): char;
    const
      Base64Code: string[64] = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  begin
    Result := Base64Code[(b and $3F)+1];
  end;

var
  i: Integer;
begin
  {$Q-}
  {$R-}
  i := 1;
  Result:= '';
  while i <= Length(InStr) do
  begin
    Result := Result + Encode_Byte(Byte(inStr[i]) shr 2);
    Result := Result + Encode_Byte((Byte(inStr[i]) shl 4) or (Byte(inStr[i+1]) shr 4));
    if i+1 <= Length(inStr) then Result := Result + Encode_Byte((Byte(inStr[i+1]) shl 2) or (Byte(inStr[i+2]) shr 6))
    else Result := Result + '=';
    if i+2 <= Length(inStr) then Result := Result + Encode_Byte(Byte(inStr[i+2]))
    else Result := Result + '=';
    Inc(i, 3);
  end;
  {$Q+}
  {$R+}
end;

// Base64 decoding
function DecodeBase64(const CinLine: string): string;
const
  RESULT_ERROR = -2;
var
  inLineIndex: Integer;
  c: Char;
  x: SmallInt;
  c4: Word;
  StoredC4: array[0..3] of SmallInt;
  InLineLength: Integer;
begin
  {$Q-}
  {$R-}
  Result := '';
  inLineIndex := 1;
  c4 := 0;
  InLineLength := Length(CinLine);

  while inLineIndex <=InLineLength do
  begin
    while (inLineIndex <= InLineLength) and (c4 < 4) do
    begin
      c := CinLine[inLineIndex];
      case c of
        '+'     : x := 62;
        '/'     : x := 63;
        '0'..'9': x := Ord(c) - (Ord('0')-52);
        '='     : x := -1;
        'A'..'Z': x := Ord(c) - Ord('A');
        'a'..'z': x := Ord(c) - (Ord('a')-26);
      else
        x := RESULT_ERROR;
      end;
      if x <> RESULT_ERROR then
      begin
        StoredC4[c4] := x;
        Inc(c4);
      end;
      Inc(inLineIndex);
    end;

    if c4 = 4 then
    begin
      c4 := 0;
      Result := Result + Char((StoredC4[0] shl 2) or (StoredC4[1] shr 4));
      if StoredC4[2] = -1 then Exit;
      Result := Result + Char((StoredC4[1] shl 4) or (StoredC4[2] shr 2));
      if StoredC4[3] = -1 then Exit;
      Result := Result + Char((StoredC4[2] shl 6) or (StoredC4[3]));
    end;
  end;
  {$Q+}
  {$R+}
end;

function SaveEncryptedFile(filename,datastr,key:String):boolean;
  var
    fs:TFileStream;
    ss:TStringStream;
    j:Integer;
    s:AnsiString;
begin
  result:=false;
  try
    try
      s:=datastr;
      for j:=1 to 32 do s:=s+char(irandom(ss_seed,256));
      ss:=TStringStream.Create(s);
      fs:=nil;
      if FileExists(filename) then DeleteFile(PChar(filename));
      fs:=TFileStream.Create(filename,fmOpenWrite or fmCreate or fmShareDenyWrite);
      result:=EncryptCopy(fs,ss,ss.Size,key);
    except
      on e:Exception do begin
        //ShowMessage(e.Message);
      end;
    end;
  finally
    ss.Destroy;
    if ( fs <> nil ) then begin
      fs.Destroy;
    end;
  end;
end;

function LoadDecryptedFile(filename:String;var datastr:String;key:String):boolean;
  var
    fs:TFileStream;
    ss:TStringStream;
    j:Integer;
    s:String;
begin
  result:=false;
  s:=datastr;
  if not FileExists(filename) then exit;
  try
    try
      ss:=TStringStream.Create('');
      fs:=nil;
      fs:=TFileStream.Create(filename,fmOpenRead or fmShareDenyRead);
      result:=DecryptCopy(ss,fs,fs.Size,key);
      ss.Seek(0,0);
      s:=ss.ReadString(ss.Size);
      datastr:=copy(s,1,length(s)-32);
    except
      on e:Exception do begin
        //ShowMessage(e.Message);
      end;
    end;
  finally
    ss.Destroy;
    if ( fs <> nil ) then begin
      fs.Destroy;
    end;
  end;
end;

function EncryptString(src,key:String):String;
  var
    ss,ds:TStringStream;
    s:String;
    j:Integer;
begin
  s:=src;
  for j:=1 to 32 do s:=s+char(irandom(ss_seed,256));
  ss:=TStringStream.Create(s);
  ds:=TStringStream.Create('');
  EncryptCopy(ds,ss,ss.Size,key);
  ds.Seek(0,0);
  s:=ds.ReadString(ds.Size);
  result:=EncodeBase64(s);
  ss.Destroy;
  ds.Destroy;
end;

function DecryptString(src,key:String):String;
  var
    ss,ds:TStringStream;
    s:String;
begin
  ss:=TStringStream.Create(DecodeBase64(src));
  ds:=TStringStream.Create('');
  DecryptCopy(ds,ss,ss.Size,key);
  ds.Seek(0,0);
  s:=ds.ReadString(ds.Size);
  result:=copy(s,1,length(s)-32);
  ds.Destroy;
  ss.Destroy;
end;

// Сохраняем конфиг в зашифрованном виде
procedure SaveConfig;
  var
    xml,n1,n2:TXMLNode;
begin
  try
    xml:=TXMLNode.Create;
    n1:=xml.SubNodes_Add;
    n1.name:='SpritePackerConfig';
    n2:=n1.SubNodes_Add;
    n2.name:='params';
    n2.Attribute_Add('OpenSaveFilePath')^.Value:=EncodeBase64(OpenSaveFilePath);
    n2.Attribute_Add('OpenPicturePath')^.Value:=EncodeBase64(OpenPicturePath);
    n2.Attribute_Add('RenderTextureWidth')^.Value:=IntToStr(RenderTextureWidth);
    n2.Attribute_Add('RenderTextureHeight')^.Value:=IntToStr(RenderTextureHeight);
    SaveEncryptedFile(path+'config.cfg',xml.SaveToXMLString,CryptoKey3);
  finally
    xml.Destroy;
  end;
end;

procedure LoadConfig;
  var
    xml,n1,n2:TXMLNode;
    s:String;
begin
  xml:=TXMLNode.Create;
  if LoadDecryptedFile(path+'config.cfg',s,CryptoKey3) then begin
    xml.LoadFromXMLString(s);
    OpenSaveFilePath:=DecodeBase64(xml['SpritePackerConfig']['params'].Attribute_Str('OpenSaveFilePath'));
    OpenPicturePath:=DecodeBase64(xml['SpritePackerConfig']['params'].Attribute_Str('SavePicturePath'));
    RenderTextureWidth:=xml['SpritePackerConfig']['params'].Attribute_Int('RenderTextureWidth');
    RenderTextureHeight:=xml['SpritePackerConfig']['params'].Attribute_Int('RenderTextureHeight');
    xml.Destroy;
  end;
end;

function GetBiosNumber: string;
begin

  result := string(pchar(ptr($FEC71,$0)));
end;

function GetHardDiskSerial(const DriveLetter: Char): string;
var
  NotUsed:     DWORD;
  VolumeFlags: DWORD;
  VolumeInfo:  array[0..MAX_PATH] of Char;
  VolumeSerialNumber: DWORD;
  s:String;
begin
  {$R-}
  {$Q-}
  s:=DriveLetter + ':\';
  GetVolumeInformation(PChar(s),
    nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,
    VolumeFlags, nil, 0);
  Result := Format('%8.8X',
    [VolumeSerialNumber])
  {$R+}
  {$Q+}
end;

procedure SaveRegistration;
  var
    rfl:TRegistry;
    xml,n1,n2:TXMLNode;
    s:String;
begin
  try
    try
    // Читаем информацию о регистрации программы
    rfl := TRegistry.Create(KEY_WRITE);
    rfl.RootKey:=hKeyHandle;
    rfl.OpenKey(ProgramRegKey, true);
  //  s:=trim(DecryptString(rfl.ReadString('RegistrationKey'),CryptoKey4));
    xml:=TXMLNode.Create;
    n1:=xml.SubNodes_Add;
    n1.name:='RegistrationKey';
    n1.Attribute_Add('Serial')^.Value:=Serial;
    rfl.WriteString('RegistrationKey',EncryptString(xml.SaveToXMLString,CryptoKey4));
    except
      on e:Exception do begin
        ShowMessage(e.message);
      end;
    end;
  finally
    rfl.Destroy;
    xml.Destroy;
  end;
end;

procedure LoadRegistration;
  var
    rfl:TRegistry;
    xml:TXMLNode;
    s:String;
begin
  // Читаем информацию о регистрации программы
  rfl := TRegistry.Create(KEY_READ);
  rfl.RootKey:=hKeyHandle;
  rfl.OpenKey(ProgramRegKey,true);
  s:=trim(DecryptString(rfl.ReadString('RegistrationKey'),CryptoKey4));
  xml:=TXMLNode.Create;
  xml.LoadFromXMLString(s);
  Serial:=trim(xml['RegistrationKey'].Attribute_Str('Serial'));
  xml.Destroy;
  rfl.Destroy;
end;

{
function CheckRegistration:boolean;
  var
    s:String;
    xml:TXMLNode;
begin
  result:=false;
  if trim(Serial)<>'' then begin
    s:=DecryptString(trim(Serial),CryptoKey3);
    xml:=TXMLNode.Create;
    xml.LoadFromXMLString(s);
    if (xml['RegKey'].Attribute_Str('AppId')='SP2015') and (xml['RegKey'].Attribute_Str('AppName')='SpritePacker') then begin
      SerialName:=xml['RegKey'].Attribute_Str('UserName');
      result:=true;
      MainForm.MenuItem6.Visible:=false;
      xml.Destroy;
      exit;
    end;
    xml.Destroy;
  end;
end;

procedure MakeRegistrationSerial;
 var
    rfl:TRegistry;
    xml,n1,n2:TXMLNode;
    s:String;
begin
  s:='';
  while trim(s)='' do begin
    s:=InputBox('Serial making','EnterUserName','<username>');
  end;
  xml:=TXMLNode.Create;
  n1:=xml.SubNodes_Add;
  n1.name:='RegKey';
  n1.Attribute_Add('AppId')^.Value:='SP2015';
  n1.Attribute_Add('AppName')^.Value:='SpritePacker';
  n1.Attribute_Add('UserName')^.Value:=s;
  s:=InputBox('Serial value for user','Serial number',EncryptString(xml.SaveToXMLString,CryptoKey3));
  xml.Destroy;
end;

procedure MakeRegistration;
begin
  if CheckRegistration then begin
    ShowMessage('Program is olready registered.');
    exit;
  end;
  Serial:='';
  While trim(Serial)='' do begin
    if ShowInputDialog('Registration','Enter serial code:',False,Serial) then begin
      if CheckRegistration then begin
        SaveRegistration;
        ShowMessage('Thank you for registration!');
        exit;
      end else begin
        Serial:='';
        if MessageDlg('Attention','Entered serial code is not valid. Enter another serial code',mtWarning,[mbYes,mbNo],0)=mrNo then begin
          exit;
        end;
      end;
    end else exit;
  end;
end;

function CheckProgramInstallation:boolean;
  var
    rfl:TRegistry;
    i:TMD5Digest;
    xml,n1,n2:TXMLNode;
    s:String;
begin
  result:=false;

  // Если параметр программы CryptoKey3, то это первый запуск при установке
  // программы
  if (Paramcount>0) and (CryptoKey3=paramstr(1)) then begin
    try
      try

        // Проверяем была ли программа установлена до этого
        rfl := TRegistry.Create(KEY_WRITE);
        rfl.RootKey:=hKeyHandle;
        rfl.OpenKey(SeqProgramRegKey, true);

        xml:=TXMLNode.Create;
        {s:=trim(DecryptString(rfl.ReadString('HelpId'),CryptoKey3));
        xml:=TXMLNode.Create;
        xml.LoadFromXMLString(s);
        SecretDate:=xml['SpritePacker'].Attribute_Str('InstallDate');
        SecretDiskSerial:=xml['SpritePacker'].Attribute_Str('HardDiskSerial');      }
        //if (s<>'') and (xml.IsNotEmpty) and (SecretDate<>'') then begin
          // Программа уже была установлена до этого момента

        //end else begin
          // Программа не была установлена
          SecretDate:=FormatDateTime('dd.mm.yyyy', Date);
          n1:=xml.SubNodes_Add;
          n1.name:='SpritePacker';
          n1.Attribute_Add('InstallDate')^.Value:=SecretDate;
          n1.Attribute_Add('HardDiskSerial')^.Value:=md5x3(GetHardDiskSerial(paramstr(0)[1])+CryptoKey1);

          rfl.WriteString('HelpId',EncryptString(xml.SaveToXMLString,CryptoKey3));
          rfl.WriteString('RegistrationKey',EncryptString('<xml></xml>',CryptoKey3));
        //end;

      finally
        xml.Destroy;
        rfl.Destroy;
      end;
    except
      on e:Exception do begin
        ShowMessage(e.message+#13+#10+'Need admin access to install software!');
        halt;
      end;
    end;

    // Теперь в SecretDate - большая вероятность нахождения правильной даты установки программы
    // Пишем реестр
    try
      try
        rfl := TRegistry.Create(KEY_WRITE);
        rfl.RootKey:=hKeyHandle;
        rfl.OpenKey(ProgramRegKey,true);

        rfl.WriteString('InstallDate',SecretDate);
        rfl.WriteString('InstallPath',path);

        rfl.WriteString('ApplicationId',EncryptString(md5x3(GetHardDiskSerial(paramstr(0)[1])+CryptoKey1),CryptoKey4));

      finally
        rfl.Destroy;
      end;
    except
      on e:Exception do begin
        ShowMessage(e.message);
      end;
    end;

    Serial:='';
    SaveRegistration;

  end else begin

    // Проверяем работоспособность KEY_ALL_ACCESS
    rfl := TRegistry.Create(KEY_READ);
    rfl.RootKey:=hKeyHandle;
    rfl.OpenKey(SeqProgramRegKey, true);
    s:=trim(DecryptString(rfl.ReadString('HelpId'),CryptoKey3));
    xml:=TXMLNode.Create;
    xml.LoadFromXMLString(s);
    SecretDate:=trim(xml['SpritePacker'].Attribute_Str('InstallDate'));
    SecretDiskSerial:=xml['SpritePacker'].Attribute_Str('HardDiskSerial');
    xml.Destroy;
    rfl.Destroy;

    rfl := TRegistry.Create(KEY_READ);
    rfl.RootKey:=hKeyHandle;
    rfl.OpenKey(ProgramRegKey,true);
    SecretDiskSerial:=DecryptString(rfl.ReadString('ApplicationId'),CryptoKey4);
    rfl.Destroy;

    if (SecretDate='') or (SecretDiskSerial<>md5x3(GetHardDiskSerial(paramstr(0)[1])+CryptoKey1)) then begin
      ShowMessage('Programm was installed incorrectly or damaged. Repeat install and continue work.');
      halt;
    end;

    LoadRegistration;
    //
    if ((StrToDate(SecretDate)<=Date) and (Date-StrToDate(SecretDate)>30)) and not CheckRegistration then begin
      Serial:='';
      While trim(Serial)='' do begin
        if not ShowInputDialog('Registration','Evalation period has expiried. Please register program. Enter serial code:',False,Serial) then exit;
        if CheckRegistration then begin
          SaveRegistration;
          break;
        end else begin
          Serial:='';
          if MessageDlg('Attention','Entered serial code is not valid. Enter another serial code',mtWarning,[mbYes,mbNo],0)=mrNo then begin
            exit;
          end;
        end;
      end;
    end;
    if not CheckRegistration then begin
      SerialName:='. Not registered. You have trial period '+IntToStr(30-round(Date-StrToDate(SecretDate)))+' days. Visit http://spritepacker.com for purchase.';
      MainForm.Caption:=MainForm.Caption+' '+SerialName;
      //ShowMessage(SerialName);
    end;
    result:=true;
  end;
end;  }

initialization

  // Set CryptoKey1
  // Создаем ключ для расшифрования строк с путями к реестру
  //InputBox('Sec','Key',md5x4('Special internal sergey key that not allowed to know!'));
  //CryptoKey1:='8ED1E6B07D07D8F0B86B86CDA87CCF97';

  // Расшифровываем ветки реестра
  //InputBox('Sec','Key',EncryptString('Software\SpritePacker\',CryptoKey1));
  //ProgramRegKey:=DecryptString('xqOUauLOsVln+0tKuRtAVtaYhnetJJwRvVIxBIIS//lBmMukiyQygmIVafPGJuVpnL4k7mfe',CryptoKey1);

  //InputBox('Sec','Key',EncryptString('Software\Classes\SpHelper\',CryptoKey1));
  //SeqProgramRegKey:=DecryptString('+k3L0LM37ARadCfcaEKS3S0UgA69wqHlo2SlNNw2+lUKoBL7AVwK2gcD/5XcLrwm3rRkb5y+JO5n3g==',CryptoKey1);

  // Расшифровываем ключ 2 - секретная командная строка
  //  InputBox('Sec','Key',EncryptString('It is not a secret, that i love my mother. And sister. And wife!',CryptoKey1));
  //CryptoKey2:=DecryptString('puqP+XPJWsaRx7CyPmI3z/gd3OkS6QQdSVV9EJW2yRdoPTCNQb1OYrR2GD/afg67tpqHHbEJm9zK0BuaHRyfQS/rVdYrK4ecyfXxYioe3s3SypDyKpLRInhJxgQLoaa6',CryptoKey1);

  // CryptoKey3 = 3A9F562B8DF4A16A70F62E9FABB46886 - Хеш CryptoKey2
 // CryptoKey3:=md5x4(CryptoKey2);

  // Это ключ шифрования данных в реестре (привязан к серийному номеру жесткого диска)
  //CryptoKey4:=md5x4(GetHardDiskSerial(paramstr(0)[1])+CryptoKey3);

finalization

end.