InraPorc

unit UFLicense;

interface

uses

  Windows, Forms, Classes, Controls, Messages, StdCtrls, Buttons, ExtCtrls,

  ComCtrls, PBNumEdit, IdBaseComponent, IdComponent, IdTCPConnection,

  IdTCPClient, IdHTTP, Dialogs, WinInet, IdIOHandler, IdIOHandlerSocket,

  IdIOHandlerStack, IdSSL, IdSSLOpenSSL;

type

  TFLicense = class(TForm)

    LLastName: TLabel;

    LCompany: TLabel;

    ELastName: TEdit;

    ECompany: TEdit;

    LFirstName: TLabel;

    EFirstName: TEdit;

    LMail: TLabel;

    EMail: TEdit;

    RBEvaluation: TRadioButton;

    RBEducation: TRadioButton;

    RBComplete: TRadioButton;

    GBLicenseType: TGroupBox;

    GBAddress: TGroupBox;

    EAddress1: TEdit;

    EAddress2: TEdit;

    EPostalCode: TEdit;

    LPostalCode: TLabel;

    ECity: TEdit;

    LCity: TLabel;

    ECountry: TEdit;

    LCountry: TLabel;

    LFax: TLabel;

    EFax: TEdit;

    LPhone: TLabel;

    EPhone: TEdit;

    PLicense: TPanel;

    BBOk: TBitBtn;

    BBCancel: TBitBtn;

    PInfo: TPanel;

    LOrganisation: TLabel;

    LLicenseNumber: TLabel;

    PBLicenseNumber: TPBNumEdit;

    PComplete: TPanel;

    PEducation: TPanel;

    LCourse: TLabel;

    ECourse: TEdit;

    REHelp: TRichEdit;

    BBHelp: TBitBtn;

    GBExport: TGroupBox;

    GBImport: TGroupBox;

    BBAutomatic: TBitBtn;

    BBImport: TBitBtn;

    SaveDialogLicFile: TSaveDialog;

    OpenDialogLicFile: TOpenDialog;

    IdHTTPLicense: TIdHTTP;

    BBManual: TBitBtn;

    IdSSL: TIdSSLIOHandlerSocketOpenSSL;

    procedure FormShow(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure RBLicenseTypeClick(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure BBHelpClick(Sender: TObject);

    procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;

    procedure BBAutomaticClick(Sender: TObject);

    procedure BBImportClick(Sender: TObject);

    procedure ECourseChange(Sender: TObject);

    procedure PBLicenseNumberChange(Sender: TObject);

    procedure EFirstNameChange(Sender: TObject);

    procedure ELastNameChange(Sender: TObject);

    procedure ECompanyChange(Sender: TObject);

    procedure EAddress1Change(Sender: TObject);

    procedure EAddress2Change(Sender: TObject);

    procedure EPostalCodeChange(Sender: TObject);

    procedure ECityChange(Sender: TObject);

    procedure ECountryChange(Sender: TObject);

    procedure EPhoneChange(Sender: TObject);

    procedure EFaxChange(Sender: TObject);

    procedure EMailChange(Sender: TObject);

    procedure BBManualClick(Sender: TObject);

  private

    { Private declarations }

    procedure DisplayLicense;

    function LicenseIsValid: Boolean;

  public

    { Public declarations }

  end;

var

  FLicense: TFLicense;

implementation

uses

  ShellAPI, SHFolder, ShlObj, SysUtils, gnugettext, UVariables, UInit, UStrings,

  UUtil, UFIntro;

{$R *.dfm}

procedure TFLicense.FormCreate(Sender: TObject);

begin

  if Screen.Fonts.IndexOf('Arial Unicode MS') <> -1

  then

    Font.Name := 'Arial Unicode MS';

  TranslateComponent(Self);

  Constraints.MinWidth := 816 + (Width - ClientWidth);

  Width := Constraints.MinWidth;

  Constraints.MinHeight := 568 + (Height - ClientHeight);

  Height := Constraints.MinHeight;

end;

procedure TFLicense.FormShow(Sender: TObject);

begin

  {

  ResName := UpperCase('License');

  Stream := TResourceStream.Create(ResInstance, ResName, 'TEXT');

  try

    REHelp.Lines.LoadFromStream(Stream);

  finally

    Stream.Free;

  end;

  }

  REHelp.Lines.Add(MsgLicense);

  DisplayLicense;

end;

procedure TFLicense.FormClose(Sender: TObject; var Action: TCloseAction);

var

  s: String;

  Ok: Boolean;

begin

  if ModalResult = mrCancel

  then

  begin

    LoadLicense;

    Exit;

  end;

  if not LicenseIsValid

  then

  begin

    Action := caNone;

    Exit;

  end;

  case LicenseType of

    1: s := 'AcceptEducation';

    2: s := 'AcceptComplete';

    else s := 'AcceptEvaluation';

  end;

  if not BdRReadBoolean('\Software\InraPorc', s, False)

  then

  begin

    FIntro := TFIntro.Create(Self);

    Ok := FIntro.ShowModal = mrOk;

    FIntro.Release;

    if Ok

    then // Accepter

      BdRWriteBoolean('\Software\InraPorc', s, True)

    else // Refuser

    begin

      Action := caNone;

      Exit;

    end;

  end;

  SaveLicense;

  if (RBComplete.Checked and not IsComplete)

  or (RBEducation.Checked and not IsEducation)

  then // Licence incorrecte

    MessageDlg (MsgInvalidLicense + sLineBreak + MsgReadOnly, mtWarning, [mbOk], 0)

  else

    if (RBEvaluation.Checked or RBEducation.Checked) and TooMuchRecords

    then // Trop d'enregistrements

      MessageDlg(MsgTooMuchRecords, mtWarning, [mbOk], 0);

end;

procedure TFLicense.RBLicenseTypeClick(Sender: TObject);

begin

  if RBComplete.Checked

  then // Compl?te

    LicenseType := 2

  else

    if RBEducation.Checked

    then // Education

      LicenseType := 1

    else // Evaluation

      LicenseType := 0;

//  PEducation.Visible := RBEducation.Checked;

  LCourse.Enabled := RBEducation.Checked;

  ECourse.Enabled := RBEducation.Checked;

//  PComplete.Visible := RBComplete.Checked;

  LLicenseNumber.Enabled := RBComplete.Checked;

  PBLicenseNumber.Enabled := RBComplete.Checked;

  PInfo.Enabled := RBComplete.Checked or RBEducation.Checked;

  EFirstName.Enabled := PInfo.Enabled;

  ELastName.Enabled := PInfo.Enabled;

  LOrganisation.Visible := RBEducation.Checked;

  LCompany.Visible := not LOrganisation.Visible;

  ECompany.Enabled := PInfo.Enabled;

  EAddress1.Enabled := PInfo.Enabled;

  EAddress2.Enabled := PInfo.Enabled;

  EPostalCode.Enabled := PInfo.Enabled;

  ECity.Enabled := PInfo.Enabled;

  ECountry.Enabled := PInfo.Enabled;

  EPhone.Enabled := PInfo.Enabled;

  EFax.Enabled := PInfo.Enabled;

  EMail.Enabled := PInfo.Enabled;

  GBExport.Enabled := PInfo.Enabled;

end;

procedure TFLicense.BBAutomaticClick(Sender: TObject);

{

const

  bSSL = True;

  sServer = 'inraporc.inra.fr';

  sScript = '/inraporc/SoftwareEnableKey.php';

  sMethod = 'POST';

  accept: packed array[0..1] of LPWSTR = (PChar('*/*'), nil);

  header: string = 'Content-Type: application/x-www-form-urlencoded';

}

var

  ParamList: TStringList;

  ResultString: string;

  {

  rbsParams: RawByteString;

  hInet, hConnect, hRequest: HINTERNET;

  port: Word;

  flag: DWORD;

  i: Integer;

  }

begin

  if not LicenseIsValid

  then

    Exit;

  BBAutomatic.Enabled := False;

  Screen.Cursor := crHourGlass;

  ParamList := TStringList.Create;

  try

    ParamList.Add(Format('Language=%s', [UpperCase(Copy(LanguageCode, 1, 2))]));

    ParamList.Add(Format('LicenseType=%d', [LicenseType]));

    ParamList.Add(Format('LicenseNumber=%d', [LicenseNumber]));

    ParamList.Add(Format('Version=%s', [VersionString]));

    ParamList.Add(Format('FirstName=%s', [FirstName]));

    ParamList.Add(Format('LastName=%s', [LastName]));

    ParamList.Add(Format('Company=%s', [Company]));

    ParamList.Add(Format('Address1=%s', [Address1]));

    ParamList.Add(Format('Address2=%s', [Address2]));

    ParamList.Add(Format('PostalCode=%s', [PostalCode]));

    ParamList.Add(Format('City=%s', [City]));

    ParamList.Add(Format('Country=%s', [Country]));

    ParamList.Add(Format('Phone=%s', [Phone]));

    ParamList.Add(Format('Fax=%s', [Fax]));

    ParamList.Add(Format('Mail=%s', [Mail]));

    ParamList.Add(Format('Course=%s', [Course]));

    ParamList.Add(Format('VolumeSerialNumber=%s', [Volume]));

    ParamList.Add(Format('FinalDate=%s', [FinalDate]));

    ParamList.Add(Format('SoftwareEnableKey=%s', [SoftwareEnableKey]));

    {

    // M?thode plus propre, mais qui n'enregistre pas les param?tre sans valeur

    ParamList.Values['Language'] := UpperCase(Copy(LanguageCode, 1, 2));

    ParamList.Values['LicenseType'] := IntToStr(LicenseType);

    ParamList.Values['LicenseNumber'] := IntToStr(LicenseNumber);

    ParamList.Values['Version'] := VersionString;

    ParamList.Values['FirstName'] := FirstName;

    ParamList.Values['LastName'] := LastName;

    ParamList.Values['Company'] := Company;

    ParamList.Values['Address1'] := Address1;

    ParamList.Values['Address2'] := Address2;

    ParamList.Values['PostalCode'] := PostalCode;

    ParamList.Values['City'] := City;

    ParamList.Values['Country'] := Country;

    ParamList.Values['Phone'] := Phone;

    ParamList.Values['Fax'] := Fax;

    ParamList.Values['Mail'] := Mail;

    ParamList.Values['Course'] := Course;

    ParamList.Values['VolumeSerialNumber'] := Volume;

    ParamList.Values['FinalDate'] := FinalDate;

    ParamList.Values['SoftwareEnableKey'] := SoftwareEnableKey;

    }

    try

      IdHTTPLicense.ConnectTimeout := 10000;

      ResultString := IdHTTPLicense.Post(URL_HTTPS + 'SoftwareEnableKey.php', ParamList);

      if ResultString <> ''

      then // Erreur PHP

        MessageDlg(ResultString, mtError, [mbOk], 0)

      else // Enregistrement effectu?

        MessageDlg(MsgLicenseSuccess, mtConfirmation, [mbOk], 0);

    except

      // Exception Delphi (Indy HTTP)

      MessageDlg(MsgServerUnreachable, mtError, [mbOk], 0);

    end;

    {

    for i := 0 to ParamList.Count - 1 do

      if i = 0 then

        rbsParams := utf8encode(ParamList[i])

      else

        rbsParams := rbsParams + '&' + utf8encode(ParamList[i]);

    hInet := InternetOpen('InraPorc', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

    if not Assigned(hInet) then

      MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOk], 0)

    else try

      if bSSL then

        port := INTERNET_DEFAULT_HTTPS_PORT

      else

        port := INTERNET_DEFAULT_HTTP_PORT;

      flag := INTERNET_SERVICE_HTTP;

      hConnect := InternetConnect(hInet, PWideChar(sServer), port, nil, nil, flag, 0, 0);

      if not Assigned(hConnect) then

        MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOk], 0)

      else try

        if bSSL then

          flag := INTERNET_FLAG_SECURE  or INTERNET_FLAG_KEEP_CONNECTION;

        hRequest := HttpOpenRequest(hConnect, PWideChar(sMethod), PWideChar(sScript), nil, nil, @accept, flag, 0);

        if not Assigned(hRequest) then

          MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOk], 0)

        else try

          flag := HTTP_ADDREQ_FLAG_ADD;

          HttpAddRequestHeaders(hRequest, Pointer(header), ByteLength(header), flag);

          if not HttpSendRequest(hRequest, nil, 0, Pointer(rbsParams), Length(rbsParams)) then

            MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOk], 0)

          else

            MessageDlg(MsgLicenseSuccess, mtConfirmation, [mbOk], 0);

        finally

          InternetCloseHandle(hRequest);

        end;

      finally

        InternetCloseHandle(hConnect);

      end;

    finally

      InternetCloseHandle(hInet);

    end;

    }

  finally

    ParamList.Free;

    Screen.Cursor:= crDefault;

    BBAutomatic.Enabled := True;

  end;

end;

procedure TFLicense.BBHelpClick(Sender: TObject);

begin

  Application.HelpCommand(HELP_CONTEXT, HelpContext);

end;

procedure TFLicense.BBImportClick(Sender: TObject);

var

  DesktopPath: array[0..MAX_PATH] of Char;

begin

  OpenDialogLicFile.FileName := 'InraPorc.lic';

  SHGetFolderPath(0, CSIDL_DESKTOP, 0, SHGFP_TYPE_CURRENT, DesktopPath);

  OpenDialogLicFile.InitialDir := DesktopPath;

  if OpenDialogLicFile.Execute

  then // Importer les informations

  begin

    LoadLicFile(OpenDialogLicFile.FileName);

    DisplayLicense;

  end;

end;

procedure TFLicense.BBManualClick(Sender: TObject);

var

  DesktopPath: array[0..MAX_PATH] of Char;

begin

  if not LicenseIsValid

  then

    Exit;

  SaveDialogLicFile.FileName := 'InraPorc.lic';

  SHGetFolderPath(0, CSIDL_DESKTOP, 0, SHGFP_TYPE_CURRENT, DesktopPath);

  SaveDialogLicFile.InitialDir := DesktopPath;

  if SaveDialogLicFile.Execute

  then // Exporter les informations

  begin

    SaveLicFile(SaveDialogLicFile.FileName);

    if Copy(LanguageCode, 1, 2) = 'fr'

    then

      ShellExecute(Handle, 'open', PChar(URL_HTTPS + 'key_fr.html'), nil, nil, SW_SHOWNORMAL)

    else

      ShellExecute(Handle, 'open', PChar(URL_HTTPS + 'key_en.html'), nil, nil, SW_SHOWNORMAL);

  end;

end;

procedure TFLicense.PBLicenseNumberChange(Sender: TObject);

begin

  LicenseNumber := PBLicenseNumber.AsInteger;

end;

procedure TFLicense.DisplayLicense;

begin

  case LicenseType of

    2: // Compl?te

      RBComplete.Checked := True;

    1: // Education

      RBEducation.Checked := True;

    else // Evaluation

      RBEvaluation.Checked := True;

  end;

  PBLicenseNumber.AsInteger := LicenseNumber;

  ECourse.Text := Course;

  EFirstName.Text := FirstName;

  ELastName.Text := LastName;

  ECompany.Text := Company;

  EAddress1.Text := Address1;

  EAddress2.Text := Address2;

  EPostalCode.Text := PostalCode;

  ECity.Text := City;

  ECountry.Text := Country;

  EPhone.Text := Phone;

  EFax.Text := Fax;

  EMail.Text := Mail;

end;

function TFLicense.LicenseIsValid: Boolean;

begin

  Result := False;

  if RBComplete.Checked and (DriveType(Drive) <> DRIVE_FIXED)

  then // La version compl?te doit ?tre install?e sur un disque fixe

  begin

    MessageDlg(MsgFixedDrive, mtWarning, [mbOk], 0);

    ActiveControl := RBComplete;

    Exit;

  end;

  if RBComplete.Checked and (LicenseNumber = 0)

  then // Num?ro de licence non renseign?

  begin

    MessageDlg(Format(MsgRequiredField, [LLicenseNumber.Caption]), mtWarning, [mbOk], 0);

    ActiveControl := PBLicenseNumber;

    Exit;

  end;

  if (RBEducation.Checked or RBComplete.Checked) and (Length(FirstName) = 0)

  then // Pr?nom non renseign?

  begin

    MessageDlg(Format(MsgRequiredField, [LFirstName.Caption]), mtWarning, [mbOk], 0);

    ActiveControl := EFirstName;

    Exit;

  end;

  if (RBEducation.Checked or RBComplete.Checked) and (Length(LastName) = 0)

  then // Nom de famille non renseign?

  begin

    MessageDlg(Format(MsgRequiredField, [LLastName.Caption]), mtWarning, [mbOk], 0);

    ActiveControl := ELastName;

    Exit;

  end;

  if RBEducation.Checked and (Length(Company) = 0)

  then // Etablissement non renseign?

  begin

    MessageDlg(Format(MsgRequiredField, [LOrganisation.Caption]), mtWarning, [mbOk], 0);

    ActiveControl := ECompany;

    Exit;

  end;

  if (RBEducation.Checked or RBComplete.Checked) and (Length(Mail) = 0)

  then // Mail non renseign?

  begin

    MessageDlg(MsgMissingMail, mtWarning, [mbOk], 0);

    ActiveControl := EMail;

    Exit;

  end;

  if RBComplete.Checked and ((Length(Address1) = 0) or (Length(City) = 0) or (Length(Country) = 0))

  then // Adresse non renseign?e

  begin

    MessageDlg(MsgMissingAddress, mtWarning, [mbOk], 0);

    ActiveControl := EAddress1;

    Exit;

  end;

  Result := True;

end;

procedure TFLicense.EAddress1Change(Sender: TObject);

begin

  Address1 := EAddress1.Text;

end;

procedure TFLicense.EAddress2Change(Sender: TObject);

begin

  Address2 := EAddress2.Text;

end;

procedure TFLicense.ECityChange(Sender: TObject);

begin

  City := ECity.Text;

end;

procedure TFLicense.ECompanyChange(Sender: TObject);

begin

  Company := ECompany.Text;

end;

procedure TFLicense.ECountryChange(Sender: TObject);

begin

  Country := ECountry.Text;

end;

procedure TFLicense.ECourseChange(Sender: TObject);

begin

  Course :=ECourse.Text;

end;

procedure TFLicense.EFaxChange(Sender: TObject);

begin

  Fax := EFax.Text;

end;

procedure TFLicense.EFirstNameChange(Sender: TObject);

begin

  FirstName := EFirstName.Text;

end;

procedure TFLicense.ELastNameChange(Sender: TObject);

begin

  LastName := ELastName.Text;

end;

procedure TFLicense.EMailChange(Sender: TObject);

begin

  Mail := EMail.Text;

end;

procedure TFLicense.EPhoneChange(Sender: TObject);

begin

  Phone := EPhone.Text;

end;

procedure TFLicense.EPostalCodeChange(Sender: TObject);

begin

  PostalCode := EPostalCode.Text;

end;

procedure TFLicense.WMSysCommand(var Message: TWMSysCommand);

begin

  if Message.CmdType = SC_MINIMIZE

  then

    Application.Minimize

  else

    inherited;

end;

end.