uses
System.DateUtils, System.Hash, System.Character, System.NetEncoding, System.Types, System.StrUtils;
function Base32Decode(
const ABase32:
string): TBytes;
const
Alphabet = '
ABCDEFGHIJKLMNOPQRSTUVWXYZ234567';
var
clean:
string;
ch: Char;
value, bits: Integer;
outIdx, idx: Integer;
buf: TBytes;
begin
clean := '
';
for ch
in ABase32
do
if (
not ch.IsWhiteSpace)
and (ch <> '
-')
and (ch <> '
=')
then
clean := clean + ch.ToUpper;
SetLength(buf, (Length(clean) * 5)
div 8 + 1);
value := 0; bits := 0; outIdx := 0;
for ch
in clean
do
begin
idx := Pos(ch, Alphabet);
if idx = 0
then
raise Exception.CreateFmt('
Ungültiges Base32-Zeichen: %s', [ch]);
value := (value
shl 5)
or (idx - 1);
Inc(bits, 5);
while bits >= 8
do
begin
Dec(bits, 8);
buf[outIdx] := (value
shr bits)
and $FF;
Inc(outIdx);
end;
end;
SetLength(buf, outIdx);
Result := buf;
end;
function BuildOtpAuthURI(
const User, Issuer, SecretBase32:
string):
string;
var
lbl:
string;
begin
lbl := TNetEncoding.URL.Encode(Format('
%s:%s', [Issuer, User]));
Result := Format('
otpauth://totp/%s?secret=%s&issuer=%s&digits=6&period=30',
[lbl, SecretBase32, TNetEncoding.URL.Encode(Issuer)]);
end;
function TOTPFromCounter(
const SecretBase32:
string; Counter: UInt64):
string;
var
SecretBytes, Msg, Hash: TBytes;
i: Integer;
tmp: UInt64;
Offset: Integer;
Binary: UInt32;
Code: UInt32;
begin
SecretBytes := Base32Decode(SecretBase32);
SetLength(Msg, 8);
tmp := Counter;
for i := 0
to 7
do
begin
Msg[7 - i] := Byte(tmp
and $FF);
tmp := tmp
shr 8;
end;
Hash := THashSHA1.GetHMACAsBytes(Msg, SecretBytes);
Offset := Hash[High(Hash)]
and $0F;
Binary := ((UInt32(Hash[Offset])
and $7F)
shl 24)
or
((UInt32(Hash[Offset+1])
and $FF)
shl 16)
or
((UInt32(Hash[Offset+2])
and $FF)
shl 8)
or
(UInt32(Hash[Offset+3])
and $FF);
Code := Binary
mod 1000000;
Result := Format('
%.6d', [Code]);
end;
function ValidateTOTP(
const SecretBase32, UserCode:
string; TimeStep: Int64 = 30; SkewSteps: Integer = 1): Boolean;
var
unixSeconds: Int64;
baseCounter: Int64;
i: Integer;
begin
unixSeconds := DateTimeToUnix(TTimeZone.
Local.ToUniversalTime(Now), True);
baseCounter := unixSeconds
div TimeStep;
for i := -SkewSteps
to SkewSteps
do
if TOTPFromCounter(SecretBase32, UInt64(baseCounter + i)) = UserCode
then
Exit(True);
Result := False;
end;
function GenerateBase32Secret(ALength: Integer):
string;
const
Alphabet = '
ABCDEFGHIJKLMNOPQRSTUVWXYZ234567';
var
i: Integer;
begin
Randomize;
Result := '
';
for i := 1
to ALength
do
Result := Result + Alphabet[Random(Length(Alphabet)) + 1];
end;
procedure GenerateQRCode(
const Text:
string; Bitmap: TBitmap);
var
QRCode: TDelphiZXingQRCode;
x, y: Integer;
Scale: Integer;
begin
QRCode := TDelphiZXingQRCode.Create;
try
QRCode.Data := Text;
Scale := 5;
Bitmap.SetSize(QRCode.Rows * Scale, QRCode.Columns * Scale);
Bitmap.Canvas.Brush.Color := clWhite;
Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
for y := 0
to QRCode.Rows - 1
do
for x := 0
to QRCode.Columns - 1
do
if QRCode.IsBlack[y, x]
then
begin
Bitmap.Canvas.Brush.Color := clBlack;
Bitmap.Canvas.FillRect(Rect(x*Scale, y*Scale,
(x+1)*Scale, (y+1)*Scale));
end;
finally
QRCode.Free;
end;
end;
procedure TForm1.btnGenerate1Click(Sender: TObject);
var
URI:
string;
bmp: TBitmap;
begin
FSecret := GenerateBase32Secret(16);
URI := BuildOtpAuthURI('
user@example.com', '
MeineApp', FSecret);
bmp := TBitmap.Create;
try
GenerateQRCode(
URI, bmp);
imgQR.Picture.Assign(bmp);
finally
bmp.Free;
end;
lblResult.Caption := '
QR-Code erzeugt. Bitte mit Authenticator scannen.';
end;
procedure TForm1.btnVerifyClick(Sender: TObject);
begin
if ValidateTOTP(FSecret, edtCode.Text)
then
lblResult.Caption := '
✅ Code korrekt!'
else
lblResult.Caption := '
❌ Ungültiger Code';
end;