unit PM.Licence;

{
  Verification hors ligne d'une licence signee ECDSA P-256.

  Une licence est une chaine "charge-utile.signature", chacune en base64url,
  fabriquee par tools\licence.ps1 avec la cle privee qui reste chez l'editeur.
  La cle PUBLIQUE seule est ici, en dur : elle ne permet que de verifier.

  CE QUE CA ARRETE, ET CE QUE CA N'ARRETE PAS. Sans la cle privee, personne ne
  fabrique de licence valable — c'est tout ce qu'un schema local peut promettre.
  Rien n'empeche de rapiecer l'exe pour sauter l'appel : c'est vrai de tous les
  schemas hors ligne, y compris ceux qui se vendent cher. La seule parade reelle
  serait de deporter une fonction sur un serveur, ce qui contredit le "100 %
  hors ligne" de cette application.

  POURQUOI AUCUN ASN.1 NULLE PART. .NET sur Windows EST CNG : la signature que
  produit le script (r||s brut, 64 octets) est deja celle qu'attend
  BCryptVerifySignature, et les coordonnees X/Y exportees se rangent telles
  quelles dans un BCRYPT_ECCPUBLIC_BLOB. Le decodage DER, moitie penible de
  l'exercice d'habitude, n'existe pas ici.

  La licence acceptee est rangee en pref DPAPI (PM.UserPrefs), donc liee au
  compte Windows et survivant au changement de port comme le reste.
}

interface

uses
  System.SysUtils, System.Classes;

type
  TLicenceInfo = record
    Holder:    string;   // nom affichable
    Email:     string;
    IssuedOn:  string;   // 'yyyy-mm-dd', date d'emission (PAS une expiration)
    Machine:   string;   // empreinte du poste, vide = licence flottante
  end;

// Verifie une chaine de licence sans rien ecrire. False = signature invalide,
// charge utile trafiquee, format casse, ou cle publique pas encore posee.
function VerifyLicence(const ALicence: string; out AInfo: TLicenceInfo): Boolean;

// Verifie puis range la licence si elle tient. C'est le point d'entree du
// bouton "Activer".
function ActivateLicence(const ALicence: string; out AInfo: TLicenceInfo): Boolean;

// Etat courant : relit la licence rangee et la REVERIFIE. Ne se contente
// jamais d'un drapeau booleen stocke — un drapeau se retourne, une signature
// se refabrique seulement avec la cle privee.
function IsLicensed: Boolean;
function LicenceInfo: TLicenceInfo;
procedure ClearLicence;

// L'empreinte de CE poste, a montrer sur l'ecran d'activation : sans elle
// l'utilisateur n'a rien a envoyer pour qu'on lui emette une licence liee.
function ThisMachineId: string;

// Verifie le chemin complet contre un vecteur de test fige. Appele a
// l'initialisation de l'unite, comme SelfTestCrypto.
procedure SelfTestLicence;

// Exposes pour PM.LicenceGate, la deuxieme couche. Ce sont des DONNEES, pas
// des decisions : elle partage la cle et le nom de la pref, et rien qui dise
// oui ou non — sinon rapiecer une seule fonction ouvrirait les deux couches.
const
  LicencePrefKey = 'licenceKey';
function LicencePublicKey: TBytes;

implementation

uses
  System.JSON, System.Hash, System.NetEncoding, Winapi.Windows,
  PM.UserPrefs, PM.MachineId;

const
  // ===== LA CLE PUBLIQUE DE L'EDITEUR ========================================
  //
  // BCRYPT_ECCPUBLIC_BLOB : magic 'ECS1' + longueur(32) + X(32) + Y(32).
  //
  // Posee le 2026-09-05, REFAITE le meme jour : la premiere privee a ete
  // supprimee sans copie. Une paire perdue interdit toute nouvelle licence a
  // jamais, et la seule reparation est celle-ci — regenerer et reemettre.
  // C'etait sans douleur avec une licence en circulation ; ca ne le sera plus.
  //
  // NE JAMAIS REGENERER SANS RAISON : toutes les licences deja emises
  // tomberaient d'un coup. Un blob a zero refuse tout, ce qui est le bon
  // defaut — un defaut qui accepterait quelque chose serait pire.
  LicencePublicKeyBlob: array[0..71] of Byte = (
    $45, $43, $53, $31, $20, $00, $00, $00, $E3, $7A, $24, $23,
    $B3, $90, $E4, $5C, $02, $7F, $49, $17, $9F, $1E, $BA, $96,
    $18, $54, $BF, $9A, $F4, $42, $E9, $1E, $A4, $AD, $32, $DF,
    $82, $7E, $54, $F4, $E7, $04, $5E, $FE, $84, $AA, $FA, $A3,
    $3F, $78, $26, $6E, $C3, $67, $8A, $2A, $F2, $B4, $CD, $0D,
    $EA, $2E, $96, $CB, $99, $71, $70, $DC, $E7, $C5, $40, $E7
  );

// ===== CNG ===================================================================

const
  STATUS_SUCCESS      = NTSTATUS(0);
  BCRYPT_ECDSA_P256   = 'ECDSA_P256';
  BCRYPT_ECCPUBLIC    = 'ECCPUBLICBLOB';
  EccBlobLen          = 72;
  P256SignatureLen    = 64;   // r||s, 32 octets chacun

function BCryptOpenAlgorithmProvider(out phAlgorithm: Pointer;
  pszAlgId, pszImplementation: PWideChar; dwFlags: ULONG): NTSTATUS; stdcall;
  external 'bcrypt.dll' name 'BCryptOpenAlgorithmProvider';

function BCryptCloseAlgorithmProvider(hAlgorithm: Pointer;
  dwFlags: ULONG): NTSTATUS; stdcall;
  external 'bcrypt.dll' name 'BCryptCloseAlgorithmProvider';

function BCryptImportKeyPair(hAlgorithm, hImportKey: Pointer;
  pszBlobType: PWideChar; out phKey: Pointer; pbInput: PByte;
  cbInput, dwFlags: ULONG): NTSTATUS; stdcall;
  external 'bcrypt.dll' name 'BCryptImportKeyPair';

function BCryptDestroyKey(hKey: Pointer): NTSTATUS; stdcall;
  external 'bcrypt.dll' name 'BCryptDestroyKey';

function BCryptVerifySignature(hKey, pPaddingInfo: Pointer;
  pbHash: PByte; cbHash: ULONG; pbSignature: PByte;
  cbSignature, dwFlags: ULONG): NTSTATUS; stdcall;
  external 'bcrypt.dll' name 'BCryptVerifySignature';

// ===== Outils ================================================================

function Base64UrlDecode(const AText: string): TBytes;
var
  LStd: string;
begin
  LStd := StringReplace(AText, '-', '+', [rfReplaceAll]);
  LStd := StringReplace(LStd, '_', '/', [rfReplaceAll]);
  while (Length(LStd) mod 4) <> 0 do
    LStd := LStd + '=';
  try
    Result := TNetEncoding.Base64.DecodeStringToBytes(LStd);
  except
    // Une chaine recopiee de travers n'est pas une panne : c'est un refus.
    Result := nil;
  end;
end;

// Verifie contre UNE cle publique donnee. La production passe la constante
// ci-dessus ; l'auto-test passe la sienne, ce qui evite de figer un second
// jeu de constantes pour la meme mecanique.
function VerifyAgainstKey(const AKeyBlob: TBytes; const AMessage,
  ASignature: TBytes): Boolean;
var
  LAlg, LKey: Pointer;
  LHash: TBytes;
  LSha: THashSHA2;
begin
  Result := False;
  if (Length(AKeyBlob) <> EccBlobLen) or
     (Length(ASignature) <> P256SignatureLen) or (Length(AMessage) = 0) then
    Exit;

  if BCryptOpenAlgorithmProvider(LAlg, BCRYPT_ECDSA_P256, nil, 0) <> STATUS_SUCCESS then
    Exit;
  try
    if BCryptImportKeyPair(LAlg, nil, BCRYPT_ECCPUBLIC, LKey,
         @AKeyBlob[0], EccBlobLen, 0) <> STATUS_SUCCESS then
      Exit;
    try
      // BCryptVerifySignature attend l'EMPREINTE, pas le message.
      LSha := THashSHA2.Create(THashSHA2.TSHA2Version.SHA256);
      LSha.Update(AMessage);
      LHash  := LSha.HashAsBytes;
      Result := BCryptVerifySignature(LKey, nil, @LHash[0], Length(LHash),
                  @ASignature[0], P256SignatureLen, 0) = STATUS_SUCCESS;
    finally
      BCryptDestroyKey(LKey);
    end;
  finally
    BCryptCloseAlgorithmProvider(LAlg, 0);
  end;
end;

function ParsePayload(const APayload: TBytes; out AInfo: TLicenceInfo): Boolean;
var
  LVal: TJSONValue;
  LObj: TJSONObject;
begin
  Result := False;
  AInfo := Default(TLicenceInfo);
  LVal := TJSONObject.ParseJSONValue(TEncoding.UTF8.GetString(APayload));
  if LVal = nil then
    Exit;
  try
    // Un transtypage direct leverait sur une charge utile qui n'est pas un
    // objet, et fuirait la valeur au passage.
    if not (LVal is TJSONObject) then
      Exit;
    LObj := TJSONObject(LVal);
    AInfo.Holder   := LObj.GetValue<string>('n', '');
    AInfo.Email    := LObj.GetValue<string>('e', '');
    AInfo.IssuedOn := LObj.GetValue<string>('d', '');
    AInfo.Machine  := LowerCase(LObj.GetValue<string>('m', ''));
    Result := AInfo.Email <> '';
  finally
    LVal.Free;
  end;
end;

function SplitAndVerify(const AKeyBlob: TBytes; const ALicence: string;
  out AInfo: TLicenceInfo): Boolean;
var
  LDot: Integer;
  LMsg, LSig: TBytes;
begin
  Result := False;
  AInfo  := Default(TLicenceInfo);

  LDot := Pos('.', ALicence);
  if (LDot < 2) or (LDot = Length(ALicence)) then
    Exit;

  LMsg := Base64UrlDecode(Copy(ALicence, 1, LDot - 1));
  LSig := Base64UrlDecode(Copy(ALicence, LDot + 1, MaxInt));
  if not VerifyAgainstKey(AKeyBlob, LMsg, LSig) then
    Exit;

  // La signature d'abord, la lecture ensuite : on n'analyse jamais une charge
  // utile dont on ne sait pas encore qu'elle vient de nous.
  Result := ParsePayload(LMsg, AInfo);
end;

// Le liage au poste, verifie APRES la signature — l'empreinte n'a de sens que
// dans une charge utile dont on sait deja qu'elle vient de nous.
//
// UNE EMPREINTE ABSENTE EST REFUSEE. Les licences flottantes ont existe le
// temps d'une seance, et l'une d'elles est sortie ; les refuser est la SEULE
// facon de l'annuler. Un schema hors ligne n'a pas de revocation — rien ne
// peut aller dire a un exe deja installe qu'une cle ne vaut plus — donc la
// seule prise qui reste est de cesser d'accepter toute une classe de cles.
//
// Ce que ca coute : plus de licence de site, une cle par poste. Assume.
//
// Consequence de bord : un poste dont l'empreinte vaut 'unavailable' (ni WMI
// ni MachineGuid) ne peut plus etre licencie du tout, puisque le script
// d'emission n'accepte que 16 caracteres hexadecimaux. C'est le bon sens de
// l'erreur : mieux vaut un poste qu'on ne peut pas licencier qu'une empreinte
// degeneree qui ouvrirait partout.
function MachineMatches(const AInfo: TLicenceInfo): Boolean;
begin
  Result := (AInfo.Machine <> '') and
            SameText(AInfo.Machine, PM.MachineId.MachineFingerprint);
end;

// ===== API ===================================================================

var
  CachedChecked: Boolean = False;
  CachedValid:   Boolean = False;
  CachedInfo:    TLicenceInfo;

function ProductionKey: TBytes;
begin
  SetLength(Result, EccBlobLen);
  Move(LicencePublicKeyBlob[0], Result[0], EccBlobLen);
end;

function LicencePublicKey: TBytes;
begin
  Result := ProductionKey;
end;

function VerifyLicence(const ALicence: string; out AInfo: TLicenceInfo): Boolean;
begin
  Result := SplitAndVerify(ProductionKey, Trim(ALicence), AInfo) and
            MachineMatches(AInfo);
end;

function ActivateLicence(const ALicence: string; out AInfo: TLicenceInfo): Boolean;
begin
  Result := VerifyLicence(ALicence, AInfo);
  if Result then
  begin
    SetPref(LicencePrefKey, Trim(ALicence));
    CachedChecked := True;
    CachedValid   := True;
    CachedInfo    := AInfo;
  end;
end;

procedure Refresh;
var
  LStored: string;
begin
  if CachedChecked then
    Exit;
  CachedChecked := True;
  LStored := GetPref(LicencePrefKey);
  CachedValid := (LStored <> '') and VerifyLicence(LStored, CachedInfo);
  if not CachedValid then
    CachedInfo := Default(TLicenceInfo);
end;

function IsLicensed: Boolean;
begin
  Refresh;
  Result := CachedValid;
end;

function LicenceInfo: TLicenceInfo;
begin
  Refresh;
  Result := CachedInfo;
end;

function ThisMachineId: string;
begin
  Result := PM.MachineId.MachineFingerprintDisplay;
end;

procedure ClearLicence;
begin
  SetPref(LicencePrefKey, '');
  CachedChecked := True;
  CachedValid   := False;
  CachedInfo    := Default(TLicenceInfo);
end;

// ===== Auto-test =============================================================

procedure SelfTestLicence;
const
  // Paire de test, sans rapport avec la cle de production : sa privee a ete
  // jetee. Elle ne prouve qu'une chose, mais elle la prouve entierement — que
  // le blob, l'empreinte et le format r||s s'accordent avec CNG.
  TestKey: array[0..71] of Byte = (
    $45, $43, $53, $31, $20, $00, $00, $00, $27, $24, $81, $FF,
    $7E, $21, $27, $90, $91, $3D, $B7, $7E, $6E, $20, $18, $8B,
    $48, $51, $D2, $DD, $1A, $BB, $3D, $E8, $65, $06, $55, $AD,
    $A3, $93, $EE, $6D, $D4, $56, $42, $9D, $F7, $85, $3C, $C9,
    $98, $FA, $42, $43, $47, $E6, $2F, $2B, $9B, $30, $6B, $15,
    $88, $AA, $2D, $C3, $79, $2B, $1E, $A2, $4D, $1F, $E3, $55
  );
  TestLicence = 'eyJuIjoiTW9uIEFtaSIsImUiOiJhbWlAZXhlbXBsZS5jb20iLCJkIjoiMjAyNi0wOS0wNSJ9.' +
                'u9q3GvBByVU0pLbuRrgT98-kZqOBSnYptJ2Mx1B1OjXxJAFgNgnxyjj8SmYpkFt1GuP2PlzRXB3A3HYRMwW2gA';
var
  LKey: TBytes;
  LInfo: TLicenceInfo;
  LTampered: string;
begin
  SetLength(LKey, EccBlobLen);
  Move(TestKey[0], LKey[0], EccBlobLen);

  if not SplitAndVerify(LKey, TestLicence, LInfo) then
    raise Exception.Create('Auto-test licence ECHOUE : une licence valable est refusee.');
  if LInfo.Email <> 'ami@exemple.com' then
    raise Exception.CreateFmt(
      'Auto-test licence ECHOUE : charge utile mal lue (got "%s").', [LInfo.Email]);

  // Un octet retourne dans la charge utile doit faire tomber la signature.
  LTampered := 'e0JuIjoiTW9uIEFtaSIsImUiOiJhbWlAZXhlbXBsZS5jb20iLCJkIjoiMjAyNi0wOS0wNSJ9.' +
               'u9q3GvBByVU0pLbuRrgT98-kZqOBSnYptJ2Mx1B1OjXxJAFgNgnxyjj8SmYpkFt1GuP2PlzRXB3A3HYRMwW2gA';
  if SplitAndVerify(LKey, LTampered, LInfo) then
    raise Exception.Create('Auto-test licence ECHOUE : une licence trafiquee est acceptee.');

  // Le liage au poste, eprouve sur l'enregistrement : on ne peut pas signer un
  // vecteur lie sans la cle privee de test, jetee — mais c'est MachineMatches
  // qui porte la regle, et c'est lui qu'il faut voir tomber.
  LInfo.Machine := '';
  if MachineMatches(LInfo) then
    raise Exception.Create('Auto-test licence ECHOUE : une licence flottante est acceptee.');
  LInfo.Machine := 'ffffffffffffffff';
  if MachineMatches(LInfo) then
    raise Exception.Create('Auto-test licence ECHOUE : une licence d''un AUTRE poste est acceptee.');
  LInfo.Machine := PM.MachineId.MachineFingerprint;
  if not MachineMatches(LInfo) then
    raise Exception.Create('Auto-test licence ECHOUE : la licence de CE poste est refusee.');
end;

initialization
  SelfTestLicence;

end.