added on local at 2026-07-01 16:01:26
| 1 | package MODS::ABForge::BuyerAuth; | |
| 2 | #====================================================================== | |
| 3 | # ABForge -- buyer-side authentication. | |
| 4 | # | |
| 5 | # Buyers are scoped to a storefront (buyer_accounts.storefront_id). | |
| 6 | # A buyer can have separate accounts at different storefronts; the | |
| 7 | # session cookie carries the buyer_id and the storefront_id so we know | |
| 8 | # which storefront the buyer is logged in to. | |
| 9 | # | |
| 10 | # Separate from MODS::Login (which authenticates CREATORS). Cookie | |
| 11 | # name is abforge_buyer_session so the two systems do not collide. | |
| 12 | # | |
| 13 | # Usage: | |
| 14 | # my $auth = MODS::ABForge::BuyerAuth->new; | |
| 15 | # my $buyer = $auth->verify($q, $db, $dbh, $DB); # hashref or undef | |
| 16 | # my ($buyer, $cookie_line) = $auth->login($db, $dbh, $DB, $sid, $email, $password); | |
| 17 | # $auth->logout($db, $dbh, $DB, $session_id); | |
| 18 | # my $buyer = $auth->signup($db, $dbh, $DB, $sid, $email, $password, $name); | |
| 19 | #====================================================================== | |
| 20 | use strict; | |
| 21 | use warnings; | |
| 22 | use Digest::SHA qw(sha1_hex); | |
| 23 | ||
| 24 | # Optional argon2id (mirrors MODS::Login). When not available we fall | |
| 25 | # back to a salted SHA-256 which is weaker but still survives the | |
| 26 | # server seeing the raw password only in transit. | |
| 27 | my $HAS_ARGON2 = 0; | |
| 28 | if (eval { require Crypt::Argon2; 1 }) { $HAS_ARGON2 = 1; } | |
| 29 | ||
| 30 | sub new { | |
| 31 | my ($class) = @_; | |
| 32 | return bless({}, $class); | |
| 33 | } | |
| 34 | ||
| 35 | # Cookie name used by all buyer-side sessions. Distinct from | |
| 36 | # abforge_session (creator) and abforge_visitor (anonymous experiment | |
| 37 | # bucket) so the three never step on each other. | |
| 38 | sub _cookie_name { 'abforge_buyer_session' } | |
| 39 | ||
| 40 | #---------------------------------------------------------------------- | |
| 41 | # Public API | |
| 42 | #---------------------------------------------------------------------- | |
| 43 | ||
| 44 | # Verify the buyer's session from the request cookie. Returns a buyer | |
| 45 | # hashref { id, storefront_id, email, display_name, session_id } when | |
| 46 | # valid; undef otherwise. | |
| 47 | sub verify { | |
| 48 | my ($self, $q, $db, $dbh, $DB) = @_; | |
| 49 | my $token = $q->cookie(_cookie_name()); | |
| 50 | return undef unless $token && length($token) >= 16; | |
| 51 | return undef if $token =~ /[^a-zA-Z0-9\-]/; | |
| 52 | ||
| 53 | return undef unless $self->_has_tables($db, $dbh, $DB); | |
| 54 | ||
| 55 | my $row = $db->db_readwrite($dbh, qq~ | |
| 56 | SELECT b.id AS id, | |
| 57 | b.storefront_id AS storefront_id, | |
| 58 | b.email AS email, | |
| 59 | b.display_name AS display_name, | |
| 60 | b.order_count AS order_count, | |
| 61 | b.lifetime_value_cents AS lifetime_value_cents, | |
| 62 | s.id AS session_id, | |
| 63 | s.expires_at | |
| 64 | FROM `${DB}`.buyer_accounts b | |
| 65 | JOIN `${DB}`.buyer_sessions s ON s.buyer_id = b.id | |
| 66 | WHERE s.id = '$token' | |
| 67 | AND s.revoked_at IS NULL | |
| 68 | AND s.expires_at > NOW() | |
| 69 | LIMIT 1 | |
| 70 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 71 | ||
| 72 | return undef unless $row && $row->{id}; | |
| 73 | return $row; | |
| 74 | } | |
| 75 | ||
| 76 | # Sign up a new buyer. Returns the new buyer hashref on success, or | |
| 77 | # a hashref { error => '...' } on failure. | |
| 78 | sub signup { | |
| 79 | my ($self, $db, $dbh, $DB, $storefront_id, $email, $password, $display_name) = @_; | |
| 80 | return { error => 'missing fields' } unless $email && $password && $storefront_id; | |
| 81 | return { error => 'invalid email' } unless $email =~ /\@/; | |
| 82 | return { error => 'password too short' } if length($password) < 8; | |
| 83 | ||
| 84 | return { error => 'database not ready' } unless $self->_has_tables($db, $dbh, $DB); | |
| 85 | ||
| 86 | $storefront_id =~ s/[^0-9]//g; | |
| 87 | my $safe_email = $email; | |
| 88 | $safe_email =~ s/[\\']/\\$&/g; | |
| 89 | my $safe_name = $display_name || ''; | |
| 90 | $safe_name =~ s/[\\']/\\$&/g; | |
| 91 | ||
| 92 | # Existing email at this storefront blocks signup. | |
| 93 | my $dup = $db->db_readwrite($dbh, qq~ | |
| 94 | SELECT id FROM `${DB}`.buyer_accounts | |
| 95 | WHERE storefront_id='$storefront_id' AND email='$safe_email' | |
| 96 | LIMIT 1 | |
| 97 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 98 | if ($dup && $dup->{id}) { | |
| 99 | return { error => 'email already in use for this storefront' }; | |
| 100 | } | |
| 101 | ||
| 102 | my $hash = _hash_password($password); | |
| 103 | $hash =~ s/[\\']/\\$&/g; | |
| 104 | ||
| 105 | my $r = $db->db_readwrite($dbh, qq~ | |
| 106 | INSERT INTO `${DB}`.buyer_accounts | |
| 107 | SET storefront_id='$storefront_id', | |
| 108 | email='$safe_email', | |
| 109 | password_hash='$hash', | |
| 110 | display_name='$safe_name', | |
| 111 | created_at=NOW() | |
| 112 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 113 | ||
| 114 | my $new_id = $r && $r->{mysql_insertid} ? $r->{mysql_insertid} : 0; | |
| 115 | return { error => 'signup failed' } unless $new_id; | |
| 116 | ||
| 117 | return $self->_load_buyer($db, $dbh, $DB, $new_id); | |
| 118 | } | |
| 119 | ||
| 120 | # Log a buyer in. Returns (buyer_hashref, set_cookie_line) on success | |
| 121 | # or ({ error => '...' }, '') on failure. | |
| 122 | sub login { | |
| 123 | my ($self, $db, $dbh, $DB, $storefront_id, $email, $password) = @_; | |
| 124 | return ({ error => 'missing fields' }, '') unless $email && $password && $storefront_id; | |
| 125 | return ({ error => 'database not ready' }, '') unless $self->_has_tables($db, $dbh, $DB); | |
| 126 | ||
| 127 | $storefront_id =~ s/[^0-9]//g; | |
| 128 | my $safe_email = $email; | |
| 129 | $safe_email =~ s/[\\']/\\$&/g; | |
| 130 | ||
| 131 | my $b = $db->db_readwrite($dbh, qq~ | |
| 132 | SELECT id, storefront_id, email, display_name, password_hash | |
| 133 | FROM `${DB}`.buyer_accounts | |
| 134 | WHERE storefront_id='$storefront_id' AND email='$safe_email' | |
| 135 | LIMIT 1 | |
| 136 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 137 | ||
| 138 | return ({ error => 'invalid email or password' }, '') unless $b && $b->{id} && $b->{password_hash}; | |
| 139 | return ({ error => 'invalid email or password' }, '') unless _verify_password($password, $b->{password_hash}); | |
| 140 | ||
| 141 | # Mint session. 30-day rolling expiry, refreshed on each login. | |
| 142 | my $sid = _uuid(); | |
| 143 | my $expires_sql = "DATE_ADD(NOW(), INTERVAL 30 DAY)"; | |
| 144 | my $ip = $ENV{REMOTE_ADDR} || ''; | |
| 145 | my $ua = substr($ENV{HTTP_USER_AGENT} || '', 0, 255); | |
| 146 | for ($ip, $ua) { s/[\\']/\\$&/g; } | |
| 147 | ||
| 148 | $db->db_readwrite($dbh, qq~ | |
| 149 | INSERT INTO `${DB}`.buyer_sessions | |
| 150 | SET id='$sid', | |
| 151 | buyer_id='$b->{id}', | |
| 152 | storefront_id='$b->{storefront_id}', | |
| 153 | user_agent='$ua', | |
| 154 | issued_at=NOW(), | |
| 155 | expires_at=$expires_sql | |
| 156 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 157 | ||
| 158 | $db->db_readwrite($dbh, qq~ | |
| 159 | UPDATE `${DB}`.buyer_accounts SET last_login_at=NOW() WHERE id='$b->{id}' | |
| 160 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 161 | ||
| 162 | my $name = _cookie_name(); | |
| 163 | my $cookie = qq~$name=$sid; Max-Age=2592000; Path=/; SameSite=Lax; HttpOnly~; | |
| 164 | ||
| 165 | delete $b->{password_hash}; | |
| 166 | $b->{session_id} = $sid; | |
| 167 | return ($b, $cookie); | |
| 168 | } | |
| 169 | ||
| 170 | # Revoke the current session. Returns the Set-Cookie line that clears | |
| 171 | # the cookie client-side. | |
| 172 | sub logout { | |
| 173 | my ($self, $db, $dbh, $DB, $session_id) = @_; | |
| 174 | return _clear_cookie() unless $self->_has_tables($db, $dbh, $DB); | |
| 175 | $session_id ||= ''; | |
| 176 | $session_id =~ s/[^a-zA-Z0-9\-]//g; | |
| 177 | if ($session_id) { | |
| 178 | $db->db_readwrite($dbh, qq~ | |
| 179 | UPDATE `${DB}`.buyer_sessions | |
| 180 | SET revoked_at=NOW() | |
| 181 | WHERE id='$session_id' | |
| 182 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 183 | } | |
| 184 | return _clear_cookie(); | |
| 185 | } | |
| 186 | ||
| 187 | #---------------------------------------------------------------------- | |
| 188 | # Internal helpers | |
| 189 | #---------------------------------------------------------------------- | |
| 190 | ||
| 191 | sub _load_buyer { | |
| 192 | my ($self, $db, $dbh, $DB, $buyer_id) = @_; | |
| 193 | $buyer_id =~ s/[^0-9]//g; | |
| 194 | return undef unless $buyer_id; | |
| 195 | my $r = $db->db_readwrite($dbh, qq~ | |
| 196 | SELECT id, storefront_id, email, display_name, order_count, lifetime_value_cents | |
| 197 | FROM `${DB}`.buyer_accounts WHERE id='$buyer_id' LIMIT 1 | |
| 198 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 199 | return $r; | |
| 200 | } | |
| 201 | ||
| 202 | sub _has_tables { | |
| 203 | my ($self, $db, $dbh, $DB) = @_; | |
| 204 | return $self->{_has_tables} if exists $self->{_has_tables}; | |
| 205 | my $r = $db->db_readwrite($dbh, qq~ | |
| 206 | SELECT | |
| 207 | (SELECT COUNT(*) FROM information_schema.tables WHERE table_schema='$DB' AND table_name='buyer_accounts') AS a, | |
| 208 | (SELECT COUNT(*) FROM information_schema.tables WHERE table_schema='$DB' AND table_name='buyer_sessions') AS s | |
| 209 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 210 | $self->{_has_tables} = ($r && $r->{a} && $r->{s}) ? 1 : 0; | |
| 211 | return $self->{_has_tables}; | |
| 212 | } | |
| 213 | ||
| 214 | sub _clear_cookie { | |
| 215 | my $name = _cookie_name(); | |
| 216 | return qq~$name=; Max-Age=0; Path=/; SameSite=Lax; HttpOnly~; | |
| 217 | } | |
| 218 | ||
| 219 | sub _hash_password { | |
| 220 | my ($plain) = @_; | |
| 221 | return '' unless defined $plain && length $plain; | |
| 222 | if ($HAS_ARGON2) { | |
| 223 | my $salt = pack('H*', sha1_hex(time() . $$ . rand())); | |
| 224 | $salt = substr($salt, 0, 16); | |
| 225 | return Crypt::Argon2::argon2id_pass($plain, $salt, 3, '32M', 1, 32); | |
| 226 | } | |
| 227 | # SHA-256 with random salt as a fallback. Stored "sha256:salt:hash". | |
| 228 | my $salt = sha1_hex(time() . $$ . rand()); | |
| 229 | my $hash = sha1_hex($salt . $plain); | |
| 230 | return "sha256:$salt:$hash"; | |
| 231 | } | |
| 232 | ||
| 233 | sub _verify_password { | |
| 234 | my ($plain, $stored) = @_; | |
| 235 | return 0 unless defined $plain && defined $stored && length $stored; | |
| 236 | if ($stored =~ /^\$argon2/ && $HAS_ARGON2) { | |
| 237 | return eval { Crypt::Argon2::argon2id_verify($stored, $plain) } ? 1 : 0; | |
| 238 | } | |
| 239 | if ($stored =~ /^sha256:([^:]+):([0-9a-f]+)$/i) { | |
| 240 | my ($salt, $expected) = ($1, $2); | |
| 241 | return sha1_hex($salt . $plain) eq $expected ? 1 : 0; | |
| 242 | } | |
| 243 | return 0; | |
| 244 | } | |
| 245 | ||
| 246 | sub _uuid { | |
| 247 | # RFC 4122 v4-ish UUID. Plenty unique for session ids. | |
| 248 | my @hex = ('0'..'9', 'a'..'f'); | |
| 249 | my $u = ''; | |
| 250 | for my $i (0..31) { | |
| 251 | $u .= $hex[int(rand(16))]; | |
| 252 | $u .= '-' if $i == 7 || $i == 11 || $i == 15 || $i == 19; | |
| 253 | } | |
| 254 | return $u; | |
| 255 | } | |
| 256 | ||
| 257 | 1; |