Skip to content

Commit 967af2e

Browse files
TekkiTekki
committed
Add support for time-based one-time passwords.
1 parent d2998eb commit 967af2e

File tree

17 files changed

+529
-23
lines changed

17 files changed

+529
-23
lines changed

‎Changes‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
Revision history for SQL-Ledger, starting with version 3.0.0
22

33
Not Released
4+
- MFA with time-based one-time passwords (codes from Authenticator App)
45
- payment screen shows links to invoices
56

67
3.2.12.55 2025-02-19

‎SL/Form.pm‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -204,7 +204,7 @@ sub dump_timer {
204204

205205

206206
sub perl_modules {
207-
return [qw|Archive::Zip Excel::Writer::XLSX Mojolicious Spreadsheet::ParseXLSX|];
207+
return [qw|Archive::Zip Excel::Writer::XLSX Mojolicious Spreadsheet::ParseXLSX Text::QRCode|];
208208
}
209209

210210

‎SL/QRCode.pm‎

Lines changed: 141 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,141 @@
1+
#=====================================================================
2+
# SQL-Ledger ERP
3+
# Copyright (C) 2025
4+
#
5+
# Author: Tekki
6+
# Web: https://tekki.ch
7+
#
8+
#======================================================================
9+
#
10+
# Generator for QR Codes
11+
#
12+
#======================================================================
13+
package SL::QRCode;
14+
15+
use POSIX 'fmax';
16+
use Text::QRCode;
17+
18+
sub plot_svg {
19+
my ($text, %param) = @_;
20+
21+
$param{background} ||= 'white';
22+
$param{dotsize} ||= 1;
23+
$param{foreground} ||= 'black';
24+
$param{height} ||= 0;
25+
$param{level} ||= 'M';
26+
$param{margin} ||= 2;
27+
$param{scale} ||= 1;
28+
$param{version} ||= 0;
29+
$param{width} ||= 0;
30+
31+
my @code = Text::QRCode->new(level => $param{level}, version => $param{version})->plot($text)->@*;
32+
33+
my $vbwidth = my $vbheight = 0;
34+
my $x_max = $code[0]->@* - 1;
35+
my $y_max = @code - 1;
36+
37+
my @elements = (qq| <rect width="100%" height="100%" fill="$param{background}"/>|);
38+
my @dot;
39+
40+
my $rect = sub {
41+
my ($x, $y, $width, $height) = @_;
42+
43+
my $x1 = $x + $param{margin};
44+
my $y1 = $y + $param{margin};
45+
$vbwidth = fmax $vbwidth, $x1 + $width;
46+
$vbheight = fmax $vbheight, $y1 + $height;
47+
48+
push @elements,
49+
qq| <rect x="$x1" y="$y1" width="$width" height="$height" fill="$param{foreground}"/>|;
50+
51+
};
52+
53+
my $add_dot = sub {
54+
if (@dot) {
55+
$rect->(@dot);
56+
@dot = ();
57+
}
58+
};
59+
60+
for my $y (0 .. $y_max) {
61+
for my $x (0 .. $x_max) {
62+
if ($code[$y][$x] eq '*') {
63+
if (@dot) {
64+
$dot[2] += $param{dotsize};
65+
} else {
66+
@dot = ($x * $param{dotsize}, $y * $param{dotsize}, $param{dotsize}, $param{dotsize});
67+
}
68+
} else {
69+
$add_dot->();
70+
}
71+
}
72+
$add_dot->();
73+
}
74+
75+
$vbheight += $param{margin};
76+
$vbwidth += $param{margin};
77+
78+
my @attr = (qq|viewBox="0 0 $vbwidth $vbheight"|);
79+
80+
my $height = $vbheight * $param{scale};
81+
my $width = $vbwidth * $param{scale};
82+
my $attributes = sprintf 'viewBox="0 0 %d %d" width="%d" height="%d"', $vbwidth, $vbheight,
83+
$param{width} || $vbwidth * $param{scale}, $param{height} || $vbheight * $param{scale};
84+
85+
my $svg
86+
= qq|<svg $attributes xmlns="http://www.w3.org/2000/svg">\n|
87+
. join("\n", @elements)
88+
. qq|\n</svg>|;
89+
90+
return $svg;
91+
}
92+
93+
1;
94+
95+
=encoding utf8
96+
97+
=head1 NAME
98+
99+
SL::QRCode - Generator for QR Codes
100+
101+
=head1 SYNOPSIS
102+
103+
use SL::QRCode;
104+
105+
my %default_params = (
106+
level => 'M',
107+
version => 0,
108+
background => 'white',
109+
foreground => 'black',
110+
dotsize => 1,
111+
width => 0,
112+
height => 0,
113+
margin => 2,
114+
scale => 1,
115+
);
116+
117+
my $svg = SL::QRCode::plot_svg($text, %default_params);
118+
119+
=head1 DESCRIPTION
120+
121+
L<SL::QRCode> provides functions to generate QR Codes.
122+
123+
=head1 DEPENDENCIES
124+
125+
L<SL::QRCode>
126+
127+
=over
128+
129+
=item * uses
130+
L<Text::QRCode>
131+
132+
=back
133+
134+
=head1 FUNCTIONS
135+
136+
=head2 plot_svg
137+
138+
my $svg = SL::QRCode::plot_svg($text);
139+
my $svg = SL::QRCode::plot_svg($text, %params);
140+
141+
=cut

‎SL/TOTP.pm‎

Lines changed: 155 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,155 @@
1+
#=====================================================================
2+
# SQL-Ledger ERP
3+
# Copyright (C) 2025
4+
#
5+
# Author: Tekki
6+
# Web: https://tekki.ch
7+
#
8+
#======================================================================
9+
#
10+
# Time-based one-time passwords
11+
#
12+
#======================================================================
13+
package SL::TOTP;
14+
15+
use Digest::SHA 'hmac_sha1';
16+
use Encode 'decode';
17+
18+
sub add_secret {
19+
my ($user, $memberfile, $userspath) = @_;
20+
21+
$user->{totp_secret} = &generate_secret;
22+
23+
if ($memberfile && $userspath) {
24+
for (qw|name signature|) {
25+
$user->{$_} = decode 'UTF-8', $user->{$_};
26+
}
27+
$user->{packpw} = 1;
28+
$user->save_member($memberfile, $userspath);
29+
}
30+
}
31+
32+
sub check_code {
33+
my ($user, $code, $timestamp) = @_;
34+
35+
$timestamp //= time;
36+
my $hash = hmac_sha1(pack('Q>', int($timestamp / 30)), decode_base32($user->{totp_secret}));
37+
my $offset = ord(substr($hash, -1)) & 0x0f;
38+
my $otp = ((unpack("N", substr($hash, $offset, 4))) & 0x7fffffff) % 10**6;
39+
40+
return sprintf("%06d", $otp) eq $code;
41+
}
42+
43+
# decode_base32 and encode_base32: from MIME::Base32 by Jens Rehsack
44+
45+
sub decode_base32 {
46+
my $arg = uc(shift || ''); # mimic MIME::Base64
47+
$arg =~ tr|A-Z2-7|\0-\37|;
48+
$arg = unpack('B*', $arg);
49+
$arg =~ s/000(.....)/$1/g;
50+
my $l = length $arg;
51+
$arg = substr($arg, 0, $l & ~7) if $l & 7;
52+
$arg = pack('B*', $arg);
53+
return $arg;
54+
}
55+
56+
sub encode_base32 {
57+
my $arg = shift;
58+
return '' unless defined($arg); # mimic MIME::Base64
59+
$arg = unpack('B*', $arg);
60+
$arg =~ s/(.....)/000$1/g;
61+
my $l = length($arg);
62+
if ($l & 7) {
63+
my $e = substr($arg, $l & ~7);
64+
$arg = substr($arg, 0, $l & ~7);
65+
$arg .= "000$e" . '0' x (5 - length $e);
66+
}
67+
$arg = pack('B*', $arg);
68+
$arg =~ tr|\0-\37|A-Z2-7|;
69+
return $arg;
70+
}
71+
72+
sub generate_secret {
73+
my $secret = join '', map { chr int rand 256 } 1 .. 20;
74+
75+
return encode_base32($secret);
76+
}
77+
78+
sub url {
79+
my ($user) = @_;
80+
81+
my $account = $user->{login};
82+
$account .= "\@$ENV{SERVER_NAME}" if $ENV{SERVER_NAME};
83+
84+
return
85+
qq|otpauth://totp/SQL-Ledger:$account?secret=$user->{totp_secret}&issuer=SQL-Ledger&algorithm=SHA1&digits=6&period=30|;
86+
}
87+
88+
1;
89+
90+
=encoding utf8
91+
92+
=head1 NAME
93+
94+
SL::TOTP - Time-based one-time passwords
95+
96+
=head1 SYNOPSIS
97+
98+
use SL::TOTP;
99+
use SL::User;
100+
101+
my $user = User->new($memberfile, $form->{login});
102+
SL::TOTP->add_secret($user, $memberfile, $userspath);
103+
104+
my $url = SL::TOTP::url($user);
105+
106+
SL::TOTP->check_code($user, $code);
107+
108+
=head1 DESCRIPTION
109+
110+
L<SL::TOTP> provides functions for time-based one-time passwords.
111+
112+
=head1 DEPENDENCIES
113+
114+
L<SL::TOTP>
115+
116+
=over
117+
118+
=item * uses
119+
L<Digest::SHA>
120+
121+
=back
122+
123+
=head1 FUNCTIONS
124+
125+
L<SL::TOTP> implements the following functions:
126+
127+
=head2 add_secret
128+
129+
my $user = User->new($memberfile, $form->{login});
130+
SL::TOTP::add_secret($user, $memberfile, $userspath);
131+
132+
SL::TOTP::add_secret($user); # without saving
133+
134+
=head2 check_code
135+
136+
my $ok = SL::TOTP::check_code($user, $code); # current time
137+
my $ok = SL::TOTP::check_code($user, $code, $timestamp);
138+
139+
=head2 decode_base32
140+
141+
my $decoded = SL::TOTP::decode_base32($encoded_string);
142+
143+
=head2 encode_base32
144+
145+
my $encoded_string = SL::TOTP::encode_base32($unencoded_string);
146+
147+
=head2 generate_secret
148+
149+
my $secret = SL::TOTP::generate_secret();
150+
151+
=head2 url
152+
153+
my $url = SL::TOTP::url($user);
154+
155+
=cut

‎SL/User.pm‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -923,7 +923,8 @@ sub config_vars {
923923
dbconnect dbdriver dbhost dbname dboptions dbpasswd
924924
dbport dbuser menuwidth name email emailcopy numberformat password
925925
outputformat printer sessionkey sid
926-
signature stylesheet tan templates timeout vclimit);
926+
signature stylesheet tan totp_activated totp_secret
927+
templates timeout vclimit);
927928

928929
@conf;
929930

0 commit comments

Comments
 (0)