From a293fff996d4ba077646290b7e7a40ab2894d462 Mon Sep 17 00:00:00 2001 From: Ilia Ross Date: Thu, 16 Apr 2026 23:08:00 +0200 Subject: [PATCH] Fix to default TOTP QR generation to QRCode::Encoder Webmin now uses the bundled QRCode::Encoder implementation by default to generate TOTP QR codes locally and inline, without relying on qr.cgi or external services. This encoder requires Perl 5.24 or newer, so qrencode is no longer included as a recommended package dependency. On older systems where the bundled encoder cannot run, admins can still install qrencode manually to restore QR generation support. Systems old enough to lack Perl 5.24 are typically already well past their supported security lifecycle, so keeping qrencode preinstalled by default is no longer treated as a packaging requirement. When neither option is available, Webmin falls back cleanly to manual TOTP setup using the shared secret. https://github.com/webmin/webmin/issues/2667#issuecomment-4247431279 [no-build] --- makedebian.pl | 2 +- makerpm.pl | 2 +- vendor_perl/Math/ReedSolomon/Encoder.pm | 117 +++++++ vendor_perl/QRCode/Encoder.pm | 252 +++++++++++++++ vendor_perl/QRCode/Encoder/Matrix.pm | 394 ++++++++++++++++++++++++ vendor_perl/QRCode/Encoder/QRSpec.pm | 292 ++++++++++++++++++ webmin/lang/en | 1 + webmin/qr.cgi | 20 -- webmin/twofactor-funcs-lib.pl | 121 ++++---- 9 files changed, 1115 insertions(+), 86 deletions(-) create mode 100644 vendor_perl/Math/ReedSolomon/Encoder.pm create mode 100644 vendor_perl/QRCode/Encoder.pm create mode 100644 vendor_perl/QRCode/Encoder/Matrix.pm create mode 100644 vendor_perl/QRCode/Encoder/QRSpec.pm delete mode 100755 webmin/qr.cgi diff --git a/makedebian.pl b/makedebian.pl index aa57b6458..cd388ab56 100755 --- a/makedebian.pl +++ b/makedebian.pl @@ -109,7 +109,7 @@ if ($product eq "webmin") { $size = int(`du -sk $tmp_dir`); @deps = ( "perl", "libnet-ssleay-perl", "openssl", "libauthen-pam-perl", "libpam-runtime", "libio-pty-perl", "unzip", "shared-mime-info", "tar", "libdigest-sha-perl", "libdigest-md5-perl", "gzip" ); $deps = join(", ", @deps); -@recommends = ( "libdatetime-perl", "libdatetime-timezone-perl", "libdatetime-locale-perl", "libtime-piece-perl", "libencode-detect-perl", "libtime-hires-perl", "libsocket6-perl", "html2text", "qrencode", "libdbi-perl", "libdbd-mysql-perl", "libdbd-mariadb-perl", "libjson-xs-perl", "libsys-syslog-perl" ); +@recommends = ( "libdatetime-perl", "libdatetime-timezone-perl", "libdatetime-locale-perl", "libtime-piece-perl", "libencode-detect-perl", "libtime-hires-perl", "libsocket6-perl", "html2text", "libdbi-perl", "libdbd-mysql-perl", "libdbd-mariadb-perl", "libjson-xs-perl", "libsys-syslog-perl" ); $recommends = join(", ", @recommends); open(CONTROL, ">$control_file"); print CONTROL <; +{ our $VERSION = '0.001' } + +use Exporter qw< import >; +our @EXPORT_OK = qw< + rs_correction + rs_correction_string + rs_encode + rs_encode_string +>; +our %EXPORT_TAGS = (all => [ @EXPORT_OK ]); + +our $ALPHA = 2; +our $PRIME_POLY = 0X11D; + +######################################################################## +# +# Public Interface + +sub rs_correction ($msg, $nsym) { + my $g = _rs_generator_poly($nsym); + my ($quot, $rem) = _gf256_poly_div([$msg->@*, (0) x $nsym ], $g); + return $rem; +} + +sub rs_correction_string ($msg, $nsym) { + my $aref = [ map { ord($_) } split m{}mxs, $msg ]; + return join '', map { chr($_) } rs_correction($aref, $nsym)->@*; +} + +sub rs_encode ($msg, $nsym) { + return [ $msg->@*, rs_correction($msg, $nsym)->@* ]; +} + +sub rs_encode_string ($msg, $nsym) { + return $msg . rs_correction_string($msg, $nsym); +} + + +######################################################################## +# +# Private Interface + +sub _rs_generator_poly ($nsym) { + state $gs = [ [1] ]; + push $gs->@*, _gf256_poly_mul($gs->[-1], [1, _gf256_pow($ALPHA, $gs->$#*)]) + while $nsym > $gs->$#*; + return $gs->[$nsym]; +} + +sub _gf256_table_for { + state $table_for = do { + my (@exp, @log); + my $x = 1; + for my $i (0 .. 254) { + $exp[$i] = $exp[$i + 255] = $x; + $log[$x] = $i; + $x <<= 1; + $x ^= $PRIME_POLY if $x & 0x100; + } + { exp => \@exp, log => \@log }; + }; +} + +sub _gf256_mul ($x, $y) { + state $table_for = _gf256_table_for(); + state $exp = $table_for->{exp}; + state $log = $table_for->{log}; + return 0 if $x == 0 || $y == 0; + return $exp->[$log->[$x] + $log->[$y]]; +} + +sub _gf256_pow ($x, $pow) { + state $table_for = _gf256_table_for(); + state $exp = $table_for->{exp}; + state $log = $table_for->{log}; + return $exp->[($log->[$x] * $pow) % 255]; +} + +sub _gf256_poly_mul ($p, $q) { + my $lp = $p->@*; + my $lq = $q->@*; + my $lr = $lp + $lq - 1; + my $r = [ (0) x $lr ]; + for my $i (0 .. ($lp - 1)) { + for my $j (0 .. ($lq - 1)) { + $r->[$i + $j] ^= _gf256_mul($p->[$i], $q->[$j]); + } + } + return $r; +} + +sub _gf256_poly_div ($x, $y) { + my $retval = [ $x->@* ]; + for my $i (0 .. ($x->$#* - $y->$#*)) { + my $c = $retval->[$i]; + if ($c != 0) { + for my $j (1 .. $y->$#*) { + if ($y->[$j] != 0) { + $retval->[$i + $j] ^= _gf256_mul($y->[$j], $c); + } + } + } + } + my $separator = $retval->$#* - $y->$#*; + my $quot = [ $retval->@[0 .. $separator] ]; + my $rem = [ $retval->@[$separator + 1 .. $retval->$#*] ]; + return ($quot, $rem); +} + +1; diff --git a/vendor_perl/QRCode/Encoder.pm b/vendor_perl/QRCode/Encoder.pm new file mode 100644 index 000000000..224990d41 --- /dev/null +++ b/vendor_perl/QRCode/Encoder.pm @@ -0,0 +1,252 @@ +package QRCode::Encoder; +use v5.24; +use warnings; +use experimental qw< signatures >; +{ our $VERSION = '0.005' } + +use Math::ReedSolomon::Encoder qw< rs_correction_string >; +use QRCode::Encoder::QRSpec qw< :all >; +use QRCode::Encoder::Matrix qw< add_matrix >; +use Exporter qw< import >; +our @EXPORT_OK = qw< + qr_best_params + qr_encode + qr_mode +>; +our %EXPORT_TAGS = (all => [ @EXPORT_OK ]); + +sub qr_mode ($octets) { + return 'numeric' if $octets =~ m{\A \d* \z}mxs; + return 'alphanumeric' + if $octets =~ m{\A [0-9A-Z\x20\x24\x25\x2a\x2b\x2d-\x2f\x3a]+ \z}mxs; + return 'kanji' + if $octets =~ m{\A + (?: # start of a pair + (?: [\x81-\x9f\xe0-\xea] [\x40-\x7e\x80-\xfc]) + | (?: \xeb [\x40-\x7e\x80\xbf]) + )+ + \z}mxs; + return 'byte'; +} + +sub qr_best_params (@args) { + state $rank_for = { L => 1, M => 2, Q => 3, H => 4 }; + my %args = scalar(@args) % 2 ? (octets => @args) : @args; + my $size = length($args{octets}); + my $mode = $args{mode} // qr_mode($args{octets}); + + my $version = $args{version}; + my $min_version = $args{'min-version'} // 1; + $version //= 40 if $min_version eq 40; + + my $level = $args{level}; + my $min_level = $args{min_level} // 'L'; + $level //= 'H' if $min_level eq 'H'; + + if (defined($level)) { + my $minv = qrspec_min_version_for($mode, $size, $level) + or die "no suitable version for $mode/$size/$level"; + if (defined($version)) { # just check + die "version $version insufficient for $mode/$size/$level" + if $version < $minv; + } + else { + my $req = $args{min_version} // 1; + $version = $minv < $req ? $req : $minv; + } + } + elsif (defined($version)) { + my $min_rank = $rank_for->{$min_level}; + for my $candidate (qw< H Q M L >) { + last if $rank_for->{$candidate} < $min_rank; + my $minv = qrspec_min_version_for($mode, $size, $candidate); + if ($minv <= $version) { + $level = $candidate; + last; + } + } + die "no level for $mode/$size/$version (min rank: $min_rank)" + unless defined $level; + } + else { # nothing is defined, go for the smaller size + $level = $min_level; + my $min_rank = $rank_for->{$level}; + my $minv = qrspec_min_version_for($mode, $size, $level); + my $req = $args{'min-version'} // 1; + $version = $minv <= $req ? $req : $minv; + for my $candidate (qw< L M Q H >) { + next if $rank_for->{$candidate} <= $min_rank; + my $altv = qrspec_min_version_for($mode, $size, $candidate); + last if $altv > $minv; + $level = $candidate; + } + } + + return ( + %args, + mode => $mode, + level => $level, + version => $version, + ); +} + +sub qr_encode (@args) { + my %args = qr_best_params(@args); + my $mode = $args{mode}; + my $level = $args{level}; + my $size = length($args{octets}); + $args{version} //= qrspec_min_version_for($mode, $size, $level); + _add_encoded(\%args); + _add_codewords(\%args); + _add_error_correction(\%args); + add_matrix(\%args); + _add_plot(\%args); + return \%args; +} + +sub _add_plot ($args) { + $args->{plot} = [ + map { [ map { $_ & 0x01 ? '*' : ' ' } $_->@* ] } $args->{matrix}->@* + ]; + return $args; +} + +sub _add_encoded ($args) { + state $encoder_for = { + numeric => \&_qr_encode_numeric, + alphanumeric => \&_qr_encode_alphanumeric, + byte => \&_qr_encode_byte, + kanji => \&_qr_encode_kanji, + }; + + my $mode = $args->{mode}; + my $encoder = $encoder_for->{$mode} or die "missing mode <$mode>\n"; + my $mi = qrspec_mode_indicator($mode); + + my $version = $args->{version}; + my $size = length($args->{octets}); + + my $lis = qrspec_length_indicator($mode, $args->{version}); + my $li = _dec2bin(length($args->{octets}), $lis); + + $args->{encoded} = $mi . $li . $encoder->($args->{octets}); + + return $args; +} + +sub _add_codewords ($args) { + my $bit_stream = $args->{encoded}; + my $data_size = qrspec_data_size($args->@{qw< version level >}); + my $needed_bits = length($bit_stream); + my $residual_bits = 8 * $data_size - $needed_bits; + die "not enough bits, wrong version?\n" if $residual_bits < 0; + my $terminator_size = $residual_bits >= 4 ? 4 : $residual_bits; + $bit_stream .= '0' x $terminator_size; + $residual_bits -= $terminator_size; + if (my $pad1 = $residual_bits % 8) { + $bit_stream .= '0' x $pad1; + $residual_bits -= $pad1; + } + while ($residual_bits > 0) { + $bit_stream .= '11101100'; + last if $residual_bits == 8; + $bit_stream .= '00010001'; + $residual_bits -= 16; + } + $args->{bit_stream} = $bit_stream; + $args->{codewords} = pack 'B*', $bit_stream; + return $args; +} + +sub _add_error_correction ($args) { + my @blocks = qrspec_ecc_spec($args->@{qw< version level >}); + $args->{ecc} = \@blocks; + my $expanded = ''; + my $codewords = $args->{codewords}; + my $i = 0; + my (@codewords, @eccs); + for my $block (@blocks) { + my ($ecc, $data, $count) = $block->@{qw< ecc data count >}; + while ($count-- > 0) { + my $cw = substr($codewords, $i, $data); + push @codewords, $cw; + push @eccs, rs_correction_string($cw, $ecc); + $i += $data; + } + } + $args->{expanded} = _linearize(\@codewords) . _linearize(\@eccs); + $args->{remainder} = qrspec_remainder($args->{version}); + return $args; +} + +sub _linearize ($strings) { + return $strings->[0] if $strings->@* == 1; + my $retval = ''; + my $i = 0; + my $n = length($strings->[-1]); + while ($i < $n) { + for my $string ($strings->@*) { + next if $i >= length($string); + $retval .= substr($string, $i, 1); + } + ++$i; + } + return $retval; +} + +sub _dec2bin ($v, $n) { substr(unpack('B*', pack('N', $v)), -$n, $n) } + +sub _qr_encode_numeric ($octets) { + state $n_bits_for = [ 4, 7, 10 ]; + my $i = 0; # index of start of substr, advanced each iteration + my $r = length($octets); # number of residual octets to take + my $bits = ''; + while ($r > 0) { + my $l = $r >= 3 ? 3 : $r; + $bits .= _dec2bin(substr($octets, $i, $l), $n_bits_for->[$l - 1]); + $r -= $l; + $i += $l; + } + return $bits; +} + +sub _qr_encode_alphanumeric ($octets) { + state $chars = [ 0 .. 9, 'A' .. 'Z', split //, ' $%*+-./:' ]; + state $value_for = { map { $chars->[$_] => $_ } 0 .. $chars->$#* }; + my $i = 0; # index of start of substr, advanced each iteration + my $r = length($octets); # number of residual octets to take + my $bits = ''; + while ($r > 0) { + if ($r == 1) { + $bits .= _dec2bin($value_for->{substr($octets, $i, 1)}, 6); + $r = 0; + } + else { + my $value = $value_for->{substr($octets, $i++, 1)} * 45; + $value += $value_for->{substr($octets, $i++, 1)}; + $bits .= _dec2bin($value, 11); + $r -= 2; + } + } + return $bits; +} + +sub _qr_encode_kanji ($octets) { + my $i = 0; + my $r = length($octets); + my $bits = ''; + while ($r > 0) { + my $v = unpack('n', substr($octets, $i, 2)); + $v -= ($v <= 0x9FFC) ? 0x8140 : 0xC140; + $v = ($v >> 8) * 0xC0 + ($v & 0xFF); + $bits .= _dec2bin($v, 13); + $r -= 2; + $i += 2; + } + return $bits; +} + +sub _qr_encode_byte ($octets) { unpack 'B*', $octets } + + +1; diff --git a/vendor_perl/QRCode/Encoder/Matrix.pm b/vendor_perl/QRCode/Encoder/Matrix.pm new file mode 100644 index 000000000..e410f1fbe --- /dev/null +++ b/vendor_perl/QRCode/Encoder/Matrix.pm @@ -0,0 +1,394 @@ +package QRCode::Encoder::Matrix; +use v5.24; +use experimental qw< signatures >; +use List::Util qw< sum >; +use QRCode::Encoder::QRSpec qw< + qrspec_version_pattern + qrspec_format_pattern + qrspec_alignment_patterns +>; + +use Exporter qw< import >; +our @EXPORT_OK = qw< add_matrix >; + +# Parts liberally taken from libqrencode/qrspec.c, which is distributed +# with LGPL license + +sub add_matrix ($data) { + add_base_matrix($data); + add_quiet($data); + add_finders($data); + add_format_reservations($data); # MUST: before add_timing + add_version($data); + add_timing($data); + add_alignments($data); + add_codewords($data); + add_mask($data); + return $data; +} + +sub stringify_matrix ($data) { + my @chunks; + my $matrix = $data->{matrix}; + for my $row ($matrix->@*) { + push @chunks, join '', map { chr($_) } $row->@*; + } + return join "\n", @chunks; +} + +sub stringify_matrix_2 ($data) { + my @chunks; + my $matrix = $data->{matrix}; + for my $row ($matrix->@*) { + push @chunks, join '', map { ($_ & 0x1) ? '#' : ' ' } $row->@*; + } + return join "\n", @chunks; +} + +sub add_base_matrix ($data) { + my $side = $data->{side_size} = 17 + 4 * $data->{version}; + my $eside = $data->{eside_size} = $side + 8; + $data->{matrix} = [ map { [ ( 0x38 ) x $eside ] } 1 .. $eside ]; + return $data; +} + +sub add_finders ($data) { + my $eside_size = $data->{eside_size}; + add_finder($data, 4 - 1, 4 - 1); + add_finder($data, 4 - 1, $eside_size - 8 - 4); + add_finder($data, $eside_size - 8 - 4, 4 - 1); + return $data; +} + +sub add_quiet ($data) { + my $es = $data->{eside_size}; + my $matrix = $data->{matrix}; + for my $i (0 .. 3) { + for my $j (0 .. $es - 1) { + $matrix->[$i][$j] = + $matrix->[$es - 1 - $i][$j] = + $matrix->[$j][$i] = + $matrix->[$j][$es - 1 - $i] = 0x30; + } + } + return $data; +} + +sub add_finder ($data, $x, $y) { + state $shape = [ + [ 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30 ], + [ 0x30, 0x31, 0x31, 0x31, 0x31, 0x31, 0x31, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x30, 0x30, 0x30, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x31, 0x31, 0x31, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x31, 0x31, 0x31, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x31, 0x31, 0x31, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x30, 0x30, 0x30, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x31, 0x31, 0x31, 0x31, 0x31, 0x31, 0x30 ], + [ 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30 ], + ]; + my $matrix = $data->{matrix}; + for my $yoff (0 .. 8) { + my $Y = $y + $yoff; + for my $xoff (0 .. 8) { + my $X = $x + $xoff; + $matrix->[$Y][$X] = $shape->[$yoff][$xoff]; + } + } + return $data; +} + +sub add_format_reservations ($data) { + my $matrix = $data->{matrix}; + my $es = $data->{eside_size}; + for my $i (0 .. 7) { + $matrix->[12][$i + 4] = + $matrix->[12][$i + $es - 4 - 8] = + $matrix->[$i + $es - 4 - 8][12] = + $matrix->[$i + 4][12] = 0x32; + } + $matrix->[12][12] = 0x32; + $matrix->[$es - 4 - 8][12] = 0x31; + return $data; +} + +sub add_version_reservations ($data) { + return $data->{version} <= 6; + + my $matrix = $data->{matrix}; + my $ecstart = $data->{eside_size} - 4 - 7 - 4; + for my $i (4 .. 9) { + for my $j ($ecstart .. ($ecstart + 2)) { + $matrix->[$i][$j] = $matrix->[$j][$i] = 0x32; + } + } + + return $data; +} + +sub add_timing ($data) { + my $matrix = $data->{matrix}; + my $es = $data->{eside_size}; + for my $i (12 .. ($es - 4 - 8 - 1)) { + $matrix->[$i][10] = $matrix->[10][$i] = 0x35 ^ ($i & 1); + } + return $data; +} + +sub try_add_alignment_pattern ($data, $x, $y) { + state $shape = [ + [ 0x31, 0x31, 0x31, 0x31, 0x31 ], + [ 0x31, 0x30, 0x30, 0x30, 0x31 ], + [ 0x31, 0x30, 0x31, 0x30, 0x31 ], + [ 0x31, 0x30, 0x30, 0x30, 0x31 ], + [ 0x31, 0x31, 0x31, 0x31, 0x31 ], + ]; + $x += 4; # offset by quiet zone + $y += 4; # offset by quiet zone + my $matrix = $data->{matrix}; + return if $matrix->[$y][$x] < 0x34 + || $matrix->[$y][$x + 4] < 0x34 + || $matrix->[$y + 4][$x] < 0x34; + for my $i (0 .. 4) { + for my $j (0 .. 4) { + $matrix->[$y + $i][$x + $j] = $shape->[$i][$j]; + } + } +} + +sub add_alignments ($data) { + my @offset = qrspec_alignment_patterns($data->{version}); + for my $y_center (@offset) { + for my $x_center (@offset) { + try_add_alignment_pattern($data, $x_center - 2, $y_center - 2); + } + } + return $data; +} + +sub bits_iterator ($data) { + my $n_expanded = length($data->{expanded}); + my $rem = $data->{remainder}; + my $i = 0; + my @queue; + return sub { + if (! @queue) { + if ($i < $n_expanded) { + push @queue, split m{}mxs, unpack 'B*', substr($data->{expanded}, $i++, 1); + } + else { + push @queue, ('0') x $rem; + $rem = 0; + } + } + return shift(@queue); + }; +} + +sub add_codewords ($data) { + my $it = bits_iterator($data); + my $matrix = $data->{matrix}; + my $side_size = $data->{side_size}; + + # start from a fake position that would be the last bit of a + # hypothetical "-1" codeword + my $x = $side_size - 2; + my $y = $side_size; + my $left = 1; + my $d = -1; # direction + while (defined(my $bit = $it->())) { + while ('necessary') { + if ($x % 2 == $left) { + ++$x; + $y += $d; + } + else { + --$x; + } + if ($d < 0 && $y < 0) { # reset condition + $x -= 2; + $y = 0; + $d = 1; + } + elsif ($d > 0 && $y >= $side_size) { # other reset condition + $x -= 2; + $y = $side_size - 1; + $d = -1; + } + if ($x == 6) { # left timing column, skip a column entirely + $x = 5; + $left = 0; + } + last if $matrix->[$y + 4][$x + 4] > 0x37; # found suitable position + } + $matrix->[$y + 4][$x + 4] = $bit ? 0x37 : 0x36; + } + return $data; +} + +sub evaluate_matrix ($matrix) { + return 0 + + evaluate_matrix_adjacents_and_11311($matrix) + + evaluate_matrix_blocks($matrix) + + evaluate_matrix_proportion($matrix); +} + +sub __row ($matrix, $i) { + my $max_idx = $matrix->[0]->$#* - 4; + join('', map { $matrix->[$i + 4][$_] & 0x01 ? 1 : 0 } 4 .. $max_idx); +} + +sub __col ($matrix, $i) { + my $max_idx = $matrix->[0]->$#* - 4; + join('', map { $matrix->[$_][$i + 4] & 0x01 ? 1 : 0 } 4 .. $max_idx); +} + +sub evaluate_matrix_adjacents_and_11311 ($matrix) { + my $side_size = $matrix->[0]->@* - 8; + my $penalty = 0; + my $penalty2 = 0; + for my $i (0 .. ($side_size - 1)) { + for my $seq (__row($matrix, $i), __col($matrix, $i)) { + + # adjacences + my @contributions = + map { $_ - 2 } + grep { $_ >= 5 } + map { length } + split m{(0+)}mxs, $seq; + $penalty += sum(@contributions) if @contributions; + + # 000011311 | 113110000 + my @matches = $seq =~ m{ + ( + (?: (?<=0000) 1011101 ) # look behind... + | (?: 1011101 (?=0000) ) # or look ahead + ) + }gmxs; + $penalty2 += 40 * scalar(@matches); + + } + } + return $penalty + $penalty2; +} + +sub evaluate_matrix_blocks ($matrix) { + my $side_size = $matrix->[0]->@* - 8; + my $penalty = 0; + for my $i (0 .. ($side_size - 2)) { + for my $j (0 .. ($side_size - 2)) { + my $count = 0; + for my $offset ([0, 0], [0, 1], [1, 0], [1, 1]) { + my ($oi, $oj) = $offset->@*; + $count++ if $matrix->[$i + $oi + 4][$j + $oj + 4] & 1; + } + $penalty += 3 if ($count == 0) || ($count == 4); + } + } + return $penalty; +} + +sub evaluate_matrix_proportion ($matrix) { + my $count = sum( map { map { $_ & 0x1 ? 1 : 0 } $_->@* } $matrix->@* ); + my $side_size = $matrix->[0]->@* - 8; + my $total = $side_size * $side_size; + my $percentage = 100 * $count / $total; + my $deviation = abs($percentage - 50); + my $penalty = 10 * int($deviation / 5); + return $penalty; +} + +sub masked_matrix ($data, $mask_id) { + state $mask_for = { + 0 => sub ($i, $j) { (($i + $j) % 2) == 0 }, + 1 => sub ($i, $j) { ($i % 2) == 0 }, + 2 => sub ($i, $j) { ($j % 3) == 0 }, + 3 => sub ($i, $j) { (($i + $j) % 3) == 0 }, + 4 => sub ($i, $j) { ((int($i / 2) + int($j / 3)) % 2) == 0 }, + 5 => sub ($i, $j) { ((($i * $j) % 2) + (($i * $j) % 3)) == 0 }, + 6 => sub ($i, $j) { (((($i * $j) % 2) + (($i * $j) % 3)) % 2) == 0 }, + 7 => sub ($i, $j) { (((($i + $j) % 2) + (($i * $j) % 3)) % 2) == 0 }, + }; + my $matrix = $data->{matrix}; + my @masked; + my $eside_size = $data->{eside_size}; + my $mask = $mask_for->{$mask_id}; + for my $i (0 .. ($eside_size - 1)) { + for my $j (0 .. ($eside_size - 1)) { + if (($matrix->[$i][$j] >= 0x36) && $mask->($i - 4, $j - 4)) { + $masked[$i][$j] = $matrix->[$i][$j] ^ 0x01; + } + else { + $masked[$i][$j] = $matrix->[$i][$j]; + } + } + } + return \@masked; +} + +sub add_mask ($data) { + my ($best_mask_id, $best_matrix, $best_penalty); + $data->{masked} = \my @masked; + for my $mask_id (0 .. 7) { + my $matrix = masked_matrix($data, $mask_id); + add_format($matrix, $data->{level}, $mask_id); + push @masked, $matrix; + my $penalty = evaluate_matrix($matrix); + ($best_mask_id, $best_matrix, $best_penalty) = ($mask_id, $matrix, $penalty) + if (! $best_matrix) || $penalty < $best_penalty; + } + $data->{original_matrix} = delete($data->{matrix}); + $data->{matrix} = $best_matrix; + $data->{mask_id} = $best_mask_id; + return $data; +} + +sub add_format ($matrix, $level, $mask_id) { + my $fmt = qrspec_format_pattern($level, $mask_id); + my $es = $matrix->[0]->@*; + + # 1st copy + my $format = $fmt; + for my $i (0 .. 7) { + $matrix->[12][$es - 1 - 4 - $i] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + for my $i (8 .. 14) { + $matrix->[$es - 1 - 4 - 14 + $i][12] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + + # 2nd copy + $format = $fmt; + for my $i (0 .. 5) { + $matrix->[4 + $i][12] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + for my $i (6, 7) { + $matrix->[4 + 1 + $i][12] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + # 8 + $matrix->[4 + 1 + 7][11] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + for my $i (9 .. 14) { + $matrix->[4 + 1 + 7][9 + 9 - $i] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + + return $matrix; +} + +sub add_version ($data) { + my $vp = qrspec_version_pattern($data->{version}) // return; + my $matrix = $data->{matrix}; + my $ecstart = $data->{eside_size} - 4 - 7 - 4; + for my $i (4 .. 9) { + for my $j ($ecstart .. ($ecstart + 2)) { + $matrix->[$i][$j] = $matrix->[$j][$i] = 0x30 ^ ($vp & 1); + $vp >>= 1; + } + } + return $data; +} + +1; diff --git a/vendor_perl/QRCode/Encoder/QRSpec.pm b/vendor_perl/QRCode/Encoder/QRSpec.pm new file mode 100644 index 000000000..df13636d2 --- /dev/null +++ b/vendor_perl/QRCode/Encoder/QRSpec.pm @@ -0,0 +1,292 @@ +package QRCode::Encoder::QRSpec; +use v5.24; +use warnings; +use experimental qw< signatures >; + +use Exporter qw< import >; +our @EXPORT_OK = qw< + qrspec_ecc_spec + qrspec_data_size + qrspec_ecc_size + qrspec_width + qrspec_remainder + qrspec_min_version + qrspec_min_version_for + qrspec_length_indicator + qrspec_maximum_words + qrspec_mode_indicator + qrspec_alignment_patterns + qrspec_format_pattern + qrspec_version_pattern +>; +our %EXPORT_TAGS = (all => [@EXPORT_OK]); + +# Liberally taken from libqrencode/qrspec.c, which is distributed with +# LGPL license + +sub qrspec_ecc_spec ($version, $level) { + state $ecc_table = [ + map { _zip_hash([qw< L M Q H >], $_) } ( + # L M Q H + [[ 1, 0], [ 1, 0], [ 1, 0], [ 1, 0]], + [[ 1, 0], [ 1, 0], [ 1, 0], [ 1, 0]], + [[ 1, 0], [ 1, 0], [ 2, 0], [ 2, 0]], + [[ 1, 0], [ 2, 0], [ 2, 0], [ 4, 0]], + [[ 1, 0], [ 2, 0], [ 2, 2], [ 2, 2]], + [[ 2, 0], [ 4, 0], [ 4, 0], [ 4, 0]], + [[ 2, 0], [ 4, 0], [ 2, 4], [ 4, 1]], + [[ 2, 0], [ 2, 2], [ 4, 2], [ 4, 2]], + [[ 2, 0], [ 3, 2], [ 4, 4], [ 4, 4]], + [[ 2, 2], [ 4, 1], [ 6, 2], [ 6, 2]], + [[ 4, 0], [ 1, 4], [ 4, 4], [ 3, 8]], + [[ 2, 2], [ 6, 2], [ 4, 6], [ 7, 4]], + [[ 4, 0], [ 8, 1], [ 8, 4], [12, 4]], + [[ 3, 1], [ 4, 5], [11, 5], [11, 5]], + [[ 5, 1], [ 5, 5], [ 5, 7], [11, 7]], + [[ 5, 1], [ 7, 3], [15, 2], [ 3, 13]], + [[ 1, 5], [10, 1], [ 1, 15], [ 2, 17]], + [[ 5, 1], [ 9, 4], [17, 1], [ 2, 19]], + [[ 3, 4], [ 3, 11], [17, 4], [ 9, 16]], + [[ 3, 5], [ 3, 13], [15, 5], [15, 10]], + [[ 4, 4], [17, 0], [17, 6], [19, 6]], + [[ 2, 7], [17, 0], [ 7, 16], [34, 0]], + [[ 4, 5], [ 4, 14], [11, 14], [16, 14]], + [[ 6, 4], [ 6, 14], [11, 16], [30, 2]], + [[ 8, 4], [ 8, 13], [ 7, 22], [22, 13]], + [[10, 2], [19, 4], [28, 6], [33, 4]], + [[ 8, 4], [22, 3], [ 8, 26], [12, 28]], + [[ 3, 10], [ 3, 23], [ 4, 31], [11, 31]], + [[ 7, 7], [21, 7], [ 1, 37], [19, 26]], + [[ 5, 10], [19, 10], [15, 25], [23, 25]], + [[13, 3], [ 2, 29], [42, 1], [23, 28]], + [[17, 0], [10, 23], [10, 35], [19, 35]], + [[17, 1], [14, 21], [29, 19], [11, 46]], + [[13, 6], [14, 23], [44, 7], [59, 1]], + [[12, 7], [12, 26], [39, 14], [22, 41]], + [[ 6, 14], [ 6, 34], [46, 10], [ 2, 64]], + [[17, 4], [29, 14], [49, 10], [24, 46]], + [[ 4, 18], [13, 32], [48, 14], [42, 32]], + [[20, 4], [40, 7], [43, 22], [10, 67]], + [[19, 6], [18, 31], [34, 34], [20, 61]], + ) + ]; + + my ($b1, $b2) = $ecc_table->[$version - 1]{$level}->@*; + my $data_size = qrspec_data_size($version, $level); + my $ecc_size = qrspec_ecc_size($version, $level); + my @retval; + + push @retval, { + count => $b1, + data => int($data_size / ($b1 + $b2)), + ecc => int($ecc_size / ($b1 + $b2)), + }; + + push @retval, { + count => $b2, + data => ($retval[0]{data} + 1), + ecc => $retval[0]{ecc}, + } if $b2; + + return @retval; +} + +sub qrspec_width ($version) { 17 + $version * 4 } + +{ + state $table = [ + map { $_->{ec} = _zip_hash([qw< L M Q H >], $_->{ec}); $_ } ( + { words => 26, remainder => 0, ec => [ 7, 10, 13, 17]}, + { words => 44, remainder => 7, ec => [ 10, 16, 22, 28]}, + { words => 70, remainder => 7, ec => [ 15, 26, 36, 44]}, + { words => 100, remainder => 7, ec => [ 20, 36, 52, 64]}, + { words => 134, remainder => 7, ec => [ 26, 48, 72, 88]}, + { words => 172, remainder => 7, ec => [ 36, 64, 96, 112]}, + { words => 196, remainder => 0, ec => [ 40, 72, 108, 130]}, + { words => 242, remainder => 0, ec => [ 48, 88, 132, 156]}, + { words => 292, remainder => 0, ec => [ 60, 110, 160, 192]}, + { words => 346, remainder => 0, ec => [ 72, 130, 192, 224]}, + { words => 404, remainder => 0, ec => [ 80, 150, 224, 264]}, + { words => 466, remainder => 0, ec => [ 96, 176, 260, 308]}, + { words => 532, remainder => 0, ec => [ 104, 198, 288, 352]}, + { words => 581, remainder => 3, ec => [ 120, 216, 320, 384]}, + { words => 655, remainder => 3, ec => [ 132, 240, 360, 432]}, + { words => 733, remainder => 3, ec => [ 144, 280, 408, 480]}, + { words => 815, remainder => 3, ec => [ 168, 308, 448, 532]}, + { words => 901, remainder => 3, ec => [ 180, 338, 504, 588]}, + { words => 991, remainder => 3, ec => [ 196, 364, 546, 650]}, + { words =>1085, remainder => 3, ec => [ 224, 416, 600, 700]}, + { words =>1156, remainder => 4, ec => [ 224, 442, 644, 750]}, + { words =>1258, remainder => 4, ec => [ 252, 476, 690, 816]}, + { words =>1364, remainder => 4, ec => [ 270, 504, 750, 900]}, + { words =>1474, remainder => 4, ec => [ 300, 560, 810, 960]}, + { words =>1588, remainder => 4, ec => [ 312, 588, 870, 1050]}, + { words =>1706, remainder => 4, ec => [ 336, 644, 952, 1110]}, + { words =>1828, remainder => 4, ec => [ 360, 700, 1020, 1200]}, + { words =>1921, remainder => 3, ec => [ 390, 728, 1050, 1260]}, + { words =>2051, remainder => 3, ec => [ 420, 784, 1140, 1350]}, + { words =>2185, remainder => 3, ec => [ 450, 812, 1200, 1440]}, + { words =>2323, remainder => 3, ec => [ 480, 868, 1290, 1530]}, + { words =>2465, remainder => 3, ec => [ 510, 924, 1350, 1620]}, + { words =>2611, remainder => 3, ec => [ 540, 980, 1440, 1710]}, + { words =>2761, remainder => 3, ec => [ 570, 1036, 1530, 1800]}, + { words =>2876, remainder => 0, ec => [ 570, 1064, 1590, 1890]}, + { words =>3034, remainder => 0, ec => [ 600, 1120, 1680, 1980]}, + { words =>3196, remainder => 0, ec => [ 630, 1204, 1770, 2100]}, + { words =>3362, remainder => 0, ec => [ 660, 1260, 1860, 2220]}, + { words =>3532, remainder => 0, ec => [ 720, 1316, 1950, 2310]}, + { words =>3706, remainder => 0, ec => [ 750, 1372, 2040, 2430]}, + ) + ]; + + sub qrspec_data_size ($version, $level) { + my $item = $table->[$version - 1]; + return $item->{words} - $item->{ec}{$level}; + } + + sub qrspec_ecc_size ($version, $level) { + return $table->[$version - 1]{ec}{$level}; + } + + sub qrspec_remainder ($version) { $table->[$version - 1]{remainder} } + + sub qrspec_min_version ($size, $level) { + state $arefs = {}; + + # first run goes through all items in the table, so this function + # is inefficient if called once per process but gets better when it + # is used multiple times per process. + my $aref = $arefs->{$level} //= do { + [ map { $_->{words} - $_->{ec}{$level} } $table->@* ] + }; + + # do not bother looking for a version if none is possible + return if $size > $aref->[-1]; + + # binary search over $aref + my ($lo, $hi) = (0, $aref->$#*); + while ($lo < $hi) { + my $mi = int(($lo + $hi) / 2); + my $misz = $aref->[$mi]; + if ($misz < $size) { $lo = $mi + 1 } # move ahead + elsif ($misz == $size) { $lo = $hi = $mi } # exact match + else { $hi = $mi } # set upper limit + } + return $lo + 1; + } +} + +{ + state $table = { + numeric => '0001', + alphanumeric => '0010', + byte => '0100', + kanji => '1000', + eci => '0111', + structured_append => '0011', + fnc1_1 => '0101', + fnc1_2 => '1001', + terminator => '0000', + }; + sub qrspec_mode_indicator ($mode) { $table->{$mode} } +} + +{ + state $table = { + numeric => [10, 12, 14], + alphanumeric => [ 9, 11, 13], + byte => [ 8, 16, 16], + kanji => [ 8, 10, 12], + }; + + sub qrspec_min_version_for ($mode, $size, $level) { + state $size_bits_for = { + numeric => sub ($s) { 10 * int($s / 3) + [0, 4, 7]->[$s % 3] }, + alphanumeric => sub ($s) { 11 * int($s / 2) + 6 * ($s % 2) }, + byte => sub ($s) { return 8 * $s }, + kanji => sub ($s) { return 13 * $s }, + }; + + my $min_bits = 4 + $size_bits_for->{$mode}->($size); + my $lengths = $table->{$mode}; + for my $i (0 .. $lengths->$#*) { + my $n_bits = $min_bits + $lengths->[$i]; + my $rem = $n_bits % 8; + my $n_words = (($n_bits - $rem) / 8) + ($rem ? 1 : 0); + my $version = qrspec_min_version($n_words, $level); + return if !defined($version); + my $j = $version <= 9 ? 0 : $version <= 26 ? 1 : 2; + return $version if $i == $j; + } + return; + } + + sub qrspec_length_indicator ($mode, $version) { + my $l = $version <= 9 ? 0 : $version <= 26 ? 1 : 2; + return $table->{$mode}[$l]; + } + + sub qrspec_maximum_words ($mode, $version) { + my $l = $version <= 9 ? 0 : $version <= 26 ? 1 : 2; + my $bits = $table->{$mode}[$l]; + my $words = (1 << $bits) - 1; + $words *= 2 if $mode eq 'kanji'; + return $words; + } +} + +sub qrspec_format_pattern ($level, $mask_id) { + state $formats_for = { + L => [0x77c4, 0x72f3, 0x7daa, 0x789d, 0x662f, 0x6318, 0x6c41, 0x6976], + M => [0x5412, 0x5125, 0x5e7c, 0x5b4b, 0x45f9, 0x40ce, 0x4f97, 0x4aa0], + Q => [0x355f, 0x3068, 0x3f31, 0x3a06, 0x24b4, 0x2183, 0x2eda, 0x2bed], + H => [0x1689, 0x13be, 0x1ce7, 0x19d0, 0x0762, 0x0255, 0x0d0c, 0x083b], + }; + return $formats_for->{$level}[$mask_id]; +} + +sub qrspec_version_pattern ($version) { + state $version_pattern_for = [ + 0x07c94, 0x085bc, 0x09a99, 0x0a4d3, # 7-10 + 0x0bbf6, 0x0c762, 0x0d847, 0x0e60d, 0x0f928, # 11-15 + 0x10b78, 0x1145d, 0x12a17, 0x13532, 0x149a6, # 16-20 + 0x15683, 0x168c9, 0x177ec, 0x18ec4, 0x191e1, # 21-25 + 0x1afab, 0x1b08e, 0x1cc1a, 0x1d33f, 0x1ed75, # 26-30 + 0x1f250, 0x209d5, 0x216f0, 0x228ba, 0x2379f, # 31-35 + 0x24b0b, 0x2542e, 0x26a64, 0x27541, 0x28c69, # 36-40 + ]; + return $version <= 6 ? undef : $version_pattern_for->[$version - 7]; +} + +sub qrspec_alignment_patterns ($version) { + state $base = [ + [18 ], [22 ], [26 ], [30 ], # 2- 5 + [34 ], [22, 38], [24, 42], [26, 46], [28, 50], # 6-10 + [30, 54], [32, 58], [34, 62], [26, 46], [26, 48], # 11-15 + [26, 50], [30, 54], [30, 56], [30, 58], [34, 62], # 16-20 + [28, 50], [26, 50], [30, 54], [28, 54], [32, 58], # 21-25 + [30, 58], [34, 62], [26, 50], [30, 54], [26, 52], # 26-30 + [30, 56], [34, 60], [30, 58], [34, 62], [30, 54], # 31-35 + [24, 50], [28, 54], [32, 58], [26, 54], [30, 58], # 35-40 + ]; + state $cache = { 1 => [] }; + my $aref = $cache->{$version} //= do { + my @offset = (6, $base->[$version - 2]->@*); + my $width = qrspec_width($version); + while ('necessary') { + my $next = 2 * $offset[-1] - $offset[-2]; + last if $next + 2 >= $width; + push @offset, $next; + } + \@offset; + }; + return $aref->@*; +} + +sub _zip_hash ($aref1, $aref2) { + my %hash; + @hash{$aref1->@*} = $aref2->@*; + return \%hash; +} + +1; diff --git a/webmin/lang/en b/webmin/lang/en index 73a28d9af..cf55942ef 100644 --- a/webmin/lang/en +++ b/webmin/lang/en @@ -1209,6 +1209,7 @@ twofactor_enrolllink=You can now enroll for two-factor authentication in the $2. twofactor_etotpmodule=The Perl module $1 needed for two-factor authentication is not installed. Use the Perl Modules page in Webmin to install it. twofactor_qrcode=Enter the secret code $1 in the TOTP app, or scan the QR code below. +twofactor_qrcode_manual=Enter the secret code $1 in the TOTP app and set it up manually, as QR code generation is not supported on this system. twofactor_etotpid=Invalid TOTP base32-encoded secret twofactor_etotptoken=TOTP token must be a number twofactor_etotpmatch=Incorrect OTP code diff --git a/webmin/qr.cgi b/webmin/qr.cgi deleted file mode 100755 index b1d7d8d32..000000000 --- a/webmin/qr.cgi +++ /dev/null @@ -1,20 +0,0 @@ -#!/usr/local/bin/perl -# Show a QR code based on parameters - -use strict; -use warnings; -no warnings 'redefine'; -no warnings 'uninitialized'; -$main::no_acl_check = 1; -require './webmin-lib.pl'; - -our (%in, %text, %gconfig, %config); -&ReadParse(); -&error_setup($text{'qr_err'}); - -$in{'str'} || &error($text{'qr_estr'}); -my ($img, $mime) = &generate_qr_code($in{'str'}, $in{'size'}); -$img || &error($mime); - -&PrintHeader(undef, $mime); -print $img; diff --git a/webmin/twofactor-funcs-lib.pl b/webmin/twofactor-funcs-lib.pl index 8a62214d7..f6e3cfadf 100644 --- a/webmin/twofactor-funcs-lib.pl +++ b/webmin/twofactor-funcs-lib.pl @@ -224,55 +224,25 @@ sub message_twofactor_totp my ($user) = @_; my $name = &get_display_hostname()." (".$user->{'name'}.")"; my $str = "otpauth://totp/".$name."?secret=".$user->{'twofactor_id'}; -my $qrcode = &ui_tag('p', - &text('twofactor_qrcode', "$user->{'twofactor_id'}")); -if (&can_generate_qr()) { - my $url; - if (&get_product_name() eq 'usermin') { - $url = "qr.cgi?size=6"; - } - else { - $url = "$gconfig{'webprefix'}/webmin/qr.cgi?size=6"; - } - my $id = "twofactor_qr_".int(time())."_".int(rand(1000000)); +my ($qrimg, $mime) = &generate_qr_code($str, 6); +if ($qrimg) { + my $qrcode = &ui_tag('p', + &text('twofactor_qrcode', "$user->{'twofactor_id'}")); + my $src = "data:$mime;base64,".&encode_base64($qrimg, 'noeol'); my $img = &ui_tag('img', undef, - { 'id' => $id, 'border' => 0, - 'style' => 'width:210px; height:210px; '. + { 'src' => $src, 'border' => 0, + 'style' => 'width:180px; height:180px; '. 'border:1px solid #444;', 'alt' => 'QR code' }); - my $id_js = "e_javascript($id); - my $url_js = "e_javascript($url); - my $str_js = "e_javascript($str); return < -(function() { -const img = document.getElementById("$id_js"), - body = "str=" + encodeURIComponent("$str_js"); -fetch("$url_js", { - method: "POST", - body: body - }).then(function(response) { - if (!response.ok) { return null; } - return response.blob(); - }).then(function(blob) { - if (!blob) { return; } - const reader = new FileReader(); - reader.onloadend = function() { img.src = reader.result; }; - reader.readAsDataURL(blob); - }).catch(function() { }); -})(); - -

+ $qrcode$img

EOF } else { - my $url = "https://api.qrserver.com/v1/create-qr-code/?". - "size=200x200&data=".&urlize($str); - my $img = &ui_tag('img', undef, - { 'src' => $url, 'border' => 0, 'alt' => 'QR code' }); return < +

@{[ &text('twofactor_qrcode_manual', + "$user->{'twofactor_id'}") ]}

+

EOF } } @@ -361,18 +331,13 @@ if (!$found && $prov) { &unlock_file($miniserv->{'twofactorfile'}); } -# can_generate_qr() -# Returns 1 if QR codes can be generated on this system -sub can_generate_qr +# can_generate_qr_encoder() +# Returns 1 if the local QRCode::Encoder fallback can be used +sub can_generate_qr_encoder { -if (&has_command("qrencode")) { - return 1; - } -eval "use Image::PNG::QRCode"; -if (!$@) { - return 1; - } -return 0; +eval "use lib (\"$root_directory/vendor_perl\")"; +eval "use QRCode::Encoder qw(qr_encode)"; +return $@ ? 0 : 1; } # generate_qr_code(string, [block-size]) @@ -380,6 +345,10 @@ return 0; sub generate_qr_code { my ($str, $size) = @_; +if (&can_generate_qr_encoder()) { + my @rv = eval { &generate_qr_code_encoder($str, $size) }; + return @rv if (!$@ && defined($rv[0])); + } if (&has_command("qrencode")) { # Use the qrencode shell command my $cmd = "qrencode -o - -t PNG ".quotemeta($str); @@ -391,19 +360,43 @@ if (&has_command("qrencode")) { } return ($out, "image/png"); } -eval "use Image::PNG::QRCode"; -if (!$@) { - # Use a Perl module - my $out; - Image::PNG::QRCode::qrpng( - text => $str, - scale => $size || 6, - out => \$out, - ); - return ($out, "image/png"); - } return (undef, "QR code generation requires either the qrencode command or ". - "Image::PNG::QRCode Perl module"); + "QRCode::Encoder Perl module"); +} + +# generate_qr_code_encoder(string, [block-size]) +# Turn a string into a QR code SVG using the local QRCode::Encoder fallback +sub generate_qr_code_encoder +{ +my ($str, $size) = @_; +eval "use lib (\"$root_directory/vendor_perl\")"; +eval "use QRCode::Encoder qw(qr_encode)"; +if ($@) { + return (undef, "QR code generation requires the ". + "QRCode::Encoder Perl module"); + } +my $encoded = qr_encode($str, level => 'M'); +my $matrix = $encoded->{'matrix'}; +my $mod_size = $size || 6; +my $count = scalar(@$matrix); +my $dim = $count * $mod_size; +my $svg = qq{}; +$svg .= qq{}; +for my $y (0 .. $#$matrix) { + for my $x (0 .. $#{$matrix->[$y]}) { + if ($matrix->[$y][$x] & 1) { + my $px = $x * $mod_size; + my $py = $y * $mod_size; + $svg .= qq{}; + } + } + } +$svg .= ""; +return ($svg, "image/svg+xml"); } 1;