added on local at 2026-07-01 15:03:20
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # ContactForge -- TOTP (RFC 6238) two-factor authentication. | |
| 4 | # | |
| 5 | # GET /twofa.cgi -> setup or status page | |
| 6 | # POST /twofa.cgi action=enable code=NNNNNN -> confirm setup | |
| 7 | # POST /twofa.cgi action=disable confirm=DISABLE | |
| 8 | # -> disable 2FA | |
| 9 | # | |
| 10 | # The implementation is pure Perl: base32 encode/decode written | |
| 11 | # inline, HMAC-SHA1 from Digest::SHA (core). No CPAN deps. | |
| 12 | # | |
| 13 | # Storage: users.two_factor_secret_enc holds the base32 secret as | |
| 14 | # bytes. The column name reads "encrypted" but we store it raw for | |
| 15 | # now; rotating to envelope-encryption with a server-held KEK is on | |
| 16 | # the roadmap. Server compromise is the only threat against this | |
| 17 | # value, and at that point the attacker has bigger leverage anyway. | |
| 18 | #====================================================================== | |
| 19 | use strict; | |
| 20 | use warnings; | |
| 21 | ||
| 22 | use lib '/var/www/vhosts/3dshawn.com/crm.3dshawn.com'; | |
| 23 | use CGI; | |
| 24 | use MODS::Template; | |
| 25 | use MODS::DBConnect; | |
| 26 | use MODS::Login; | |
| 27 | use MODS::ContactForge::Config; | |
| 28 | use MODS::ContactForge::Wrapper; | |
| 29 | use Digest::SHA qw(hmac_sha1); | |
| 30 | ||
| 31 | $|=1; | |
| 32 | ||
| 33 | my $q = CGI->new; | |
| 34 | my $form = $q->Vars; | |
| 35 | my $auth = MODS::Login->new; | |
| 36 | my $tfile = MODS::Template->new; | |
| 37 | my $db = MODS::DBConnect->new; | |
| 38 | my $cfg = MODS::ContactForge::Config->new; | |
| 39 | my $wrap = MODS::ContactForge::Wrapper->new; | |
| 40 | my $DB = $cfg->settings('database_name'); | |
| 41 | ||
| 42 | my $userinfo = $auth->login_verify(); | |
| 43 | unless ($userinfo) { | |
| 44 | print "Status: 302 Found\nLocation: /login.cgi\n\n"; | |
| 45 | exit; | |
| 46 | } | |
| 47 | my $uid = $userinfo->{user_id}; | |
| 48 | $uid =~ s/[^0-9]//g; | |
| 49 | ||
| 50 | my $dbh = $db->db_connect(); | |
| 51 | ||
| 52 | # Load current 2FA state. | |
| 53 | my $u = $db->db_readwrite($dbh, qq~ | |
| 54 | SELECT email, two_factor_enabled, two_factor_secret_enc | |
| 55 | FROM `${DB}`.users WHERE id='$uid' LIMIT 1 | |
| 56 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 57 | my $is_enabled = ($u && $u->{two_factor_enabled}) ? 1 : 0; | |
| 58 | my $current_email = $u ? ($u->{email} || '') : ''; | |
| 59 | ||
| 60 | my $err = ''; | |
| 61 | ||
| 62 | # ---------- POST: enable / disable ----------------------------------- | |
| 63 | if (($ENV{REQUEST_METHOD} || '') eq 'POST') { | |
| 64 | my $act = $form->{action} || ''; | |
| 65 | ||
| 66 | if ($act eq 'enable' && !$is_enabled) { | |
| 67 | my $candidate = $form->{candidate_secret} || ''; | |
| 68 | $candidate =~ s/[^A-Z2-7]//gi; | |
| 69 | $candidate = uc $candidate; | |
| 70 | my $code = $form->{code} || ''; | |
| 71 | $code =~ s/\D//g; | |
| 72 | ||
| 73 | if (length($candidate) < 16) { | |
| 74 | $err = 'Setup secret missing or corrupted. Reload the page and try again.'; | |
| 75 | } | |
| 76 | elsif (length($code) != 6) { | |
| 77 | $err = 'Enter the 6-digit code from your authenticator app.'; | |
| 78 | } | |
| 79 | elsif (!_totp_verify($candidate, $code)) { | |
| 80 | $err = 'Code did not match. Check that your phone\'s clock is correct and try again.'; | |
| 81 | } | |
| 82 | else { | |
| 83 | # Commit. Store the secret bytes; mark 2FA on. | |
| 84 | my $safe = $candidate; | |
| 85 | $safe =~ s/'/''/g; | |
| 86 | $db->db_readwrite($dbh, qq~ | |
| 87 | UPDATE `${DB}`.users | |
| 88 | SET two_factor_enabled=1, | |
| 89 | two_factor_secret_enc='$safe' | |
| 90 | WHERE id='$uid' LIMIT 1 | |
| 91 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 92 | $db->db_disconnect($dbh); | |
| 93 | print "Status: 302 Found\nLocation: /profile.cgi?twofa=enabled#security\n\n"; | |
| 94 | exit; | |
| 95 | } | |
| 96 | } | |
| 97 | elsif ($act eq 'disable' && $is_enabled) { | |
| 98 | if (($form->{confirm} || '') ne 'DISABLE') { | |
| 99 | $err = 'Type DISABLE in the confirmation box to turn off 2FA.'; | |
| 100 | } else { | |
| 101 | $db->db_readwrite($dbh, qq~ | |
| 102 | UPDATE `${DB}`.users | |
| 103 | SET two_factor_enabled=0, | |
| 104 | two_factor_secret_enc=NULL | |
| 105 | WHERE id='$uid' LIMIT 1 | |
| 106 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 107 | $db->db_disconnect($dbh); | |
| 108 | print "Status: 302 Found\nLocation: /profile.cgi?twofa=disabled#security\n\n"; | |
| 109 | exit; | |
| 110 | } | |
| 111 | } | |
| 112 | } | |
| 113 | ||
| 114 | $db->db_disconnect($dbh); | |
| 115 | ||
| 116 | # ---------- GET: render either setup or status ----------------------- | |
| 117 | my $candidate = ''; | |
| 118 | my $otpauth = ''; | |
| 119 | if (!$is_enabled) { | |
| 120 | # Fresh setup: mint a candidate secret. We don't store it server- | |
| 121 | # side until the rep proves they can read it (POST action=enable | |
| 122 | # with a valid 6-digit code). The candidate is stamped into a | |
| 123 | # hidden form field so the POST round-trip carries it back. | |
| 124 | $candidate = _gen_secret(20); # 160 bits, RFC 4226 recommended | |
| 125 | my $label = "ContactForge:$current_email"; | |
| 126 | my $issuer = 'ContactForge'; | |
| 127 | $otpauth = "otpauth://totp/" . _urlenc($label) | |
| 128 | . "?secret=$candidate&issuer=" . _urlenc($issuer) | |
| 129 | . "&algorithm=SHA1&digits=6&period=30"; | |
| 130 | } | |
| 131 | ||
| 132 | my $tvars = { | |
| 133 | is_enabled => $is_enabled, | |
| 134 | is_disabled => $is_enabled ? 0 : 1, | |
| 135 | email => _h($current_email), | |
| 136 | candidate_secret => $candidate, | |
| 137 | candidate_chunked => _chunked_for_display($candidate), | |
| 138 | otpauth_uri => _h($otpauth), | |
| 139 | has_err => length($err) ? 1 : 0, | |
| 140 | err => _h($err), | |
| 141 | }; | |
| 142 | ||
| 143 | print "Content-Type: text/html; charset=utf-8\nCache-Control: no-store, no-cache, must-revalidate, max-age=0\nPragma: no-cache\nExpires: 0\n\n"; | |
| 144 | my $body = join('', $tfile->template('cf_twofa.html', $tvars, $userinfo)); | |
| 145 | $wrap->render({ | |
| 146 | userinfo => $userinfo, | |
| 147 | page_key => 'my_profile', | |
| 148 | title => 'Two-factor authentication', | |
| 149 | body => $body, | |
| 150 | }); | |
| 151 | exit; | |
| 152 | ||
| 153 | #====================================================================== | |
| 154 | # TOTP helpers (RFC 6238) | |
| 155 | #====================================================================== | |
| 156 | ||
| 157 | # Generate $n random bytes of secret, return as base32. | |
| 158 | sub _gen_secret { | |
| 159 | my ($n) = @_; | |
| 160 | my $bytes = ''; | |
| 161 | # Try /dev/urandom first (cryptographically strong on Linux). | |
| 162 | if (open(my $fh, '<', '/dev/urandom')) { | |
| 163 | binmode $fh; | |
| 164 | read($fh, $bytes, $n); | |
| 165 | close $fh; | |
| 166 | } | |
| 167 | # Fallback (much weaker, but better than failing). | |
| 168 | while (length($bytes) < $n) { | |
| 169 | $bytes .= chr(int(rand(256))); | |
| 170 | } | |
| 171 | return _base32_encode(substr($bytes, 0, $n)); | |
| 172 | } | |
| 173 | ||
| 174 | # Verify a 6-digit code against a base32 secret. Allows +/- 1 step | |
| 175 | # of clock drift either way (so ~90 seconds of acceptance window). | |
| 176 | sub _totp_verify { | |
| 177 | my ($secret_b32, $code) = @_; | |
| 178 | return 0 unless $secret_b32 && $code && $code =~ /^\d{6}$/; | |
| 179 | foreach my $w (-1, 0, 1) { | |
| 180 | return 1 if _totp_at($secret_b32, time() + $w * 30) eq $code; | |
| 181 | } | |
| 182 | return 0; | |
| 183 | } | |
| 184 | ||
| 185 | sub _totp_at { | |
| 186 | my ($secret_b32, $t) = @_; | |
| 187 | my $key = _base32_decode($secret_b32); | |
| 188 | my $counter = int($t / 30); | |
| 189 | # 8-byte big-endian counter | |
| 190 | my $cnt = pack('NN', int($counter / 2**32), $counter % (2**32)); | |
| 191 | my $hmac = hmac_sha1($cnt, $key); | |
| 192 | my $offset = ord(substr($hmac, -1)) & 0x0F; | |
| 193 | my $code = ( | |
| 194 | ((ord(substr($hmac, $offset, 1)) & 0x7F) << 24) | | |
| 195 | ((ord(substr($hmac, $offset+1, 1)) & 0xFF) << 16) | | |
| 196 | ((ord(substr($hmac, $offset+2, 1)) & 0xFF) << 8) | | |
| 197 | (ord(substr($hmac, $offset+3, 1)) & 0xFF) | |
| 198 | ) % 1_000_000; | |
| 199 | return sprintf('%06d', $code); | |
| 200 | } | |
| 201 | ||
| 202 | sub _base32_encode { | |
| 203 | my ($bytes) = @_; | |
| 204 | my $alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567'; | |
| 205 | my $bits = unpack('B*', $bytes); | |
| 206 | # Pad to multiple of 5 | |
| 207 | my $pad = (5 - length($bits) % 5) % 5; | |
| 208 | $bits .= '0' x $pad; | |
| 209 | my $out = ''; | |
| 210 | while ($bits =~ /(.{5})/g) { | |
| 211 | $out .= substr($alphabet, oct("0b$1"), 1); | |
| 212 | } | |
| 213 | return $out; | |
| 214 | } | |
| 215 | ||
| 216 | sub _base32_decode { | |
| 217 | my ($s) = @_; | |
| 218 | $s = uc $s; | |
| 219 | $s =~ s/[^A-Z2-7]//g; | |
| 220 | my %v; | |
| 221 | my @alpha = split //, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567'; | |
| 222 | for (my $i = 0; $i < @alpha; $i++) { $v{ $alpha[$i] } = sprintf('%05b', $i); } | |
| 223 | my $bits = join('', map { $v{$_} // '' } split //, $s); | |
| 224 | # Trim to multiple of 8 | |
| 225 | my $usable = length($bits) - (length($bits) % 8); | |
| 226 | $bits = substr($bits, 0, $usable); | |
| 227 | return pack('B*', $bits); | |
| 228 | } | |
| 229 | ||
| 230 | sub _urlenc { | |
| 231 | my $s = shift // ''; | |
| 232 | $s =~ s/([^A-Za-z0-9_.~-])/sprintf("%%%02X", ord($1))/ge; | |
| 233 | return $s; | |
| 234 | } | |
| 235 | ||
| 236 | # Split a base32 secret into space-separated groups of 4 chars so it's | |
| 237 | # easy to type into an authenticator app's manual-entry field. | |
| 238 | sub _chunked_for_display { | |
| 239 | my $s = shift // ''; | |
| 240 | my @grp; | |
| 241 | while (length $s) { | |
| 242 | push @grp, substr($s, 0, 4, ''); | |
| 243 | } | |
| 244 | return join(' ', @grp); | |
| 245 | } | |
| 246 | ||
| 247 | sub _h { | |
| 248 | my $s = shift // ''; | |
| 249 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 250 | $s =~ s/"/"/g; $s =~ s/'/'/g; | |
| 251 | return $s; | |
| 252 | } |