unit PMA.Totp;
{
  Codes TOTP (RFC 6238) - la raison principale de sortir son telephone.

  Rien de specifique a Android : base32, HMAC-SHA1, troncature dynamique. Le
  poste Windows a deja son implementation en JavaScript ; celle-ci est la
  meme mecanique, verifiee contre les memes vecteurs de la RFC.

  Le secret arrive soit en base32 nu, soit en URI otpauth:// - les deux
  circulent dans les instantanes selon la facon dont l'entree a ete creee.
  On accepte les deux, et l'URI fournit en prime sa periode et son nombre de
  chiffres quand ils different des valeurs par defaut.
}

interface

uses
  System.SysUtils;

/// Code courant pour ASecret, et le temps restant avant renouvellement.
/// Retourne '' si le secret est vide ou illisible - jamais d'exception : un
/// mauvais secret ne doit pas empecher l'affichage du reste de l'entree.
function TotpNow(const ASecret: string; out ASecondsLeft, APeriod: Integer): string;

/// Meme chose a un instant donne. Existe pour que les vecteurs de la RFC
/// soient verifiables : ils sont tous exprimes a une date fixe.
function TotpAt(const ASecret: string; AUnix: Int64;
  out ASecondsLeft, APeriod: Integer): string;

implementation

uses
  System.Classes, System.Hash, System.DateUtils, System.NetEncoding;

const
  B32 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567';

function Base32Decode(const S: string): TBytes;
var
  I, LBits, LValue, LIdx, LPos: Integer;
  LCh: Char;
begin
  SetLength(Result, Length(S));   // majorant : 5 bits par caractere
  LBits := 0; LValue := 0; LIdx := 0;
  for I := 1 to Length(S) do
  begin
    LCh := UpCase(S[I]);
    // Espaces, tirets et remplissage sont ignores : les secrets se
    // recopient souvent par groupes de quatre.
    LPos := Pos(LCh, B32);
    if LPos = 0 then Continue;
    LValue := (LValue shl 5) or (LPos - 1);
    Inc(LBits, 5);
    if LBits >= 8 then
    begin
      Result[LIdx] := (LValue shr (LBits - 8)) and $FF;
      Inc(LIdx);
      Dec(LBits, 8);
    end;
  end;
  SetLength(Result, LIdx);
end;

/// Valeur d'un parametre de requete dans une URI otpauth://, ou '' s'il
/// manque. Assez pour secret/period/digits, sans tirer un analyseur d'URI.
function UriParam(const AUri, AName: string): string;
var
  LStart, LEnd: Integer;
  LKey: string;
begin
  Result := '';
  LKey := '?' + AName + '=';
  LStart := Pos(LKey, AUri);
  if LStart = 0 then
  begin
    LKey := '&' + AName + '=';
    LStart := Pos(LKey, AUri);
    if LStart = 0 then Exit;
  end;
  Inc(LStart, Length(LKey));
  LEnd := LStart;
  while (LEnd <= Length(AUri)) and (AUri[LEnd] <> '&') do Inc(LEnd);
  Result := Copy(AUri, LStart, LEnd - LStart);
end;

function TotpNow(const ASecret: string; out ASecondsLeft, APeriod: Integer): string;
begin
  // Toujours en UTC : un decalage horaire ferait un code faux tout en
  // paraissant parfaitement valide.
  Result := TotpAt(ASecret,
              DateTimeToUnix(TTimeZone.Local.ToUniversalTime(Now), True),
              ASecondsLeft, APeriod);
end;

function TotpAt(const ASecret: string; AUnix: Int64;
  out ASecondsLeft, APeriod: Integer): string;
var
  LSecret: string;
  LDigits, LOffset, LBinary, LMod, I: Integer;
  LKey, LMsg, LHash: TBytes;
  LCounter: Int64;
begin
  Result := '';
  ASecondsLeft := 0;
  APeriod := 30;
  LDigits := 6;

  LSecret := ASecret.Trim;
  if LSecret = '' then Exit;

  if LSecret.ToLower.StartsWith('otpauth://') then
  begin
    if UriParam(LSecret, 'period') <> '' then
      APeriod := StrToIntDef(UriParam(LSecret, 'period'), 30);
    if UriParam(LSecret, 'digits') <> '' then
      LDigits := StrToIntDef(UriParam(LSecret, 'digits'), 6);
    LSecret := UriParam(LSecret, 'secret');
    if LSecret = '' then Exit;
  end;

  if (APeriod <= 0) or (LDigits < 6) or (LDigits > 8) then Exit;

  LKey := Base32Decode(LSecret);
  if Length(LKey) = 0 then Exit;

  LCounter := AUnix div APeriod;
  ASecondsLeft := APeriod - (AUnix mod APeriod);

  // Compteur sur 8 octets, gros-boutiste.
  SetLength(LMsg, 8);
  for I := 7 downto 0 do
  begin
    LMsg[I] := Byte(LCounter and $FF);
    LCounter := LCounter shr 8;
  end;

  LHash := THashSHA1.GetHMACAsBytes(LMsg, LKey);
  if Length(LHash) < 20 then Exit;

  // Troncature dynamique : les 4 derniers bits designent l'offset.
  LOffset := LHash[19] and $0F;
  LBinary := ((LHash[LOffset]     and $7F) shl 24) or
             ((LHash[LOffset + 1] and $FF) shl 16) or
             ((LHash[LOffset + 2] and $FF) shl 8)  or
              (LHash[LOffset + 3] and $FF);

  LMod := 1;
  for I := 1 to LDigits do LMod := LMod * 10;
  Result := Format('%.*d', [LDigits, LBinary mod LMod]);
end;

end.