added on local at 2026-07-01 21:47:12
| 1 | package MODS::RePricer::Permissions; | |
| 2 | #====================================================================== | |
| 3 | # RePricer - role-based permission checks. | |
| 4 | # | |
| 5 | # Backs Wrapper.pm sidebar filtering and the require_feature() page | |
| 6 | # guards CGIs call before rendering. The model: | |
| 7 | # | |
| 8 | # * users.permission_groups_id IS NULL -> owner / unconstrained. | |
| 9 | # Every feature passes; no DB lookup needed. | |
| 10 | # * users.permission_groups_id IS NOT NULL -> team member. | |
| 11 | # The permission_groups row carries permission_features_ids (CSV | |
| 12 | # of feature ids); only those slugs/ids resolve to true. | |
| 13 | # | |
| 14 | # Cached on $userinfo per-request: features_csv + slug_to_id. That way | |
| 15 | # a page that calls has_feature() ten times only hits the DB once. | |
| 16 | #====================================================================== | |
| 17 | use strict; | |
| 18 | ||
| 19 | my $db; | |
| 20 | if (eval { require MODS::DBConnect; 1 }) { | |
| 21 | $db = MODS::DBConnect->new; | |
| 22 | } | |
| 23 | my $config; | |
| 24 | if (eval { require MODS::Config; 1 }) { | |
| 25 | $config = MODS::Config->new; | |
| 26 | } | |
| 27 | my $DB = $config ? $config->settings('database_name') : ''; | |
| 28 | ||
| 29 | sub new { | |
| 30 | my ($class) = @_; | |
| 31 | return bless({}, $class); | |
| 32 | } | |
| 33 | ||
| 34 | #---------------------------------------------------------------------- | |
| 35 | # Returns 1 if $userinfo has access to the given feature, else 0. | |
| 36 | # $userinfo -- hashref returned by Login::login_verify | |
| 37 | # $slug_or_id -- 'edit_models' or numeric '13' | |
| 38 | # | |
| 39 | # Owners (permission_groups_id NULL) ALWAYS get 1. Unauthenticated | |
| 40 | # callers get 0. | |
| 41 | #---------------------------------------------------------------------- | |
| 42 | sub has_feature { | |
| 43 | my ($self, $userinfo, $slug_or_id) = @_; | |
| 44 | return 0 unless $userinfo && $userinfo->{user_id}; | |
| 45 | ||
| 46 | # Owner / unconstrained | |
| 47 | my $pg = $userinfo->{permission_groups_id}; | |
| 48 | return 1 if !defined($pg) || $pg eq ''; | |
| 49 | ||
| 50 | my ($csv, $slug_map) = $self->_load_cached($userinfo); | |
| 51 | return 0 unless defined $csv; | |
| 52 | ||
| 53 | my $id = ($slug_or_id =~ /^\d+$/) ? $slug_or_id : ($slug_map->{$slug_or_id} || 0); | |
| 54 | return 0 unless $id; | |
| 55 | return (",$csv," =~ m/,$id,/) ? 1 : 0; | |
| 56 | } | |
| 57 | ||
| 58 | #---------------------------------------------------------------------- | |
| 59 | # Page-entry guard. If $userinfo lacks $slug_or_id, sends a redirect | |
| 60 | # and exits. Owner accounts always pass through. Admins-impersonating | |
| 61 | # pass through (impersonation gives admins target-user data scope but | |
| 62 | # we don't want them locked out of admin tools mid-impersonation). | |
| 63 | # | |
| 64 | # $redirect_to is optional; defaults to /dashboard.cgi for sellers, | |
| 65 | # /admin.cgi for admins. | |
| 66 | #---------------------------------------------------------------------- | |
| 67 | sub require_feature { | |
| 68 | my ($self, $userinfo, $slug_or_id, $redirect_to) = @_; | |
| 69 | ||
| 70 | return if $self->has_feature($userinfo, $slug_or_id); | |
| 71 | ||
| 72 | # Admin in impersonation mode: treat as owner-equivalent. Admins | |
| 73 | # should not get bounced out of admin pages just because they're | |
| 74 | # acting as a team-member-target. | |
| 75 | return if $userinfo && $userinfo->{_impersonating}; | |
| 76 | ||
| 77 | if (!$redirect_to) { | |
| 78 | $redirect_to = ($userinfo && $userinfo->{is_admin}) | |
| 79 | ? '/admin.cgi?denied=' . $slug_or_id | |
| 80 | : '/dashboard.cgi?denied=' . $slug_or_id; | |
| 81 | } | |
| 82 | print "Status: 302 Found\nLocation: $redirect_to\n\n"; | |
| 83 | exit; | |
| 84 | } | |
| 85 | ||
| 86 | #---------------------------------------------------------------------- | |
| 87 | # require_owner($userinfo, [$redirect_to]) | |
| 88 | # | |
| 89 | # Owner-only guard. Blocks team members (rows with non-null | |
| 90 | # owner_user_id) entirely -- no role grants access. Used by billing, | |
| 91 | # team management, plan changes, and any other "principal-only" pages. | |
| 92 | # Admin impersonation passes through, same reasoning as require_feature. | |
| 93 | #---------------------------------------------------------------------- | |
| 94 | sub require_owner { | |
| 95 | my ($self, $userinfo, $redirect_to) = @_; | |
| 96 | return if $userinfo && $userinfo->{_impersonating}; | |
| 97 | return if $userinfo && !$userinfo->{owner_user_id}; | |
| 98 | ||
| 99 | $redirect_to ||= '/dashboard.cgi?denied=owner_only'; | |
| 100 | print "Status: 302 Found\nLocation: $redirect_to\n\n"; | |
| 101 | exit; | |
| 102 | } | |
| 103 | ||
| 104 | #---------------------------------------------------------------------- | |
| 105 | # is_owner($userinfo) — bool. Convenience for templates / CGIs that | |
| 106 | # need to *render* something differently rather than redirect. | |
| 107 | #---------------------------------------------------------------------- | |
| 108 | sub is_owner { | |
| 109 | my ($self, $userinfo) = @_; | |
| 110 | return 0 unless $userinfo; | |
| 111 | return ($userinfo->{owner_user_id}) ? 0 : 1; | |
| 112 | } | |
| 113 | ||
| 114 | #---------------------------------------------------------------------- | |
| 115 | # is_super_admin($userinfo) — bool. Super-admin is the platform owner | |
| 116 | # (founder seat). Required for /admin_config.cgi which edits Stripe | |
| 117 | # keys, branding, and other platform-wide secrets. is_admin alone is | |
| 118 | # NOT enough -- a staff admin can manage users without holding the | |
| 119 | # keys to the kingdom. | |
| 120 | # | |
| 121 | # Implicit invariant: is_super_admin implies is_admin. We check both | |
| 122 | # because a downgraded super-admin row could otherwise still reach | |
| 123 | # the platform-wide config surface. | |
| 124 | #---------------------------------------------------------------------- | |
| 125 | sub is_super_admin { | |
| 126 | my ($self, $userinfo) = @_; | |
| 127 | return 0 unless $userinfo; | |
| 128 | return 0 unless $userinfo->{is_admin}; | |
| 129 | ||
| 130 | # Cached per request. Login.pm intentionally does NOT include | |
| 131 | # is_super_admin in its SELECT so the login query stays compatible | |
| 132 | # with pre-migration installs. We probe lazily here and stash. | |
| 133 | return $userinfo->{_super_admin} if exists $userinfo->{_super_admin}; | |
| 134 | ||
| 135 | my $uid = $userinfo->{user_id}; | |
| 136 | $uid =~ s/[^0-9]//g if defined $uid; | |
| 137 | return 0 unless $uid; | |
| 138 | return 0 unless $db && $DB; | |
| 139 | ||
| 140 | my $dbh = $db->db_connect(); | |
| 141 | return 0 unless $dbh; | |
| 142 | ||
| 143 | # Guard for the column-not-yet-migrated state so a brand-new | |
| 144 | # install doesn't 500 the admin pages. | |
| 145 | my $col_check = $db->db_readwrite($dbh, qq~ | |
| 146 | SELECT COUNT(*) AS n FROM information_schema.columns | |
| 147 | WHERE table_schema='$DB' AND table_name='users' | |
| 148 | AND column_name='is_super_admin' | |
| 149 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 150 | unless ($col_check && $col_check->{n}) { | |
| 151 | $db->db_disconnect($dbh); | |
| 152 | $userinfo->{_super_admin} = 0; | |
| 153 | return 0; | |
| 154 | } | |
| 155 | ||
| 156 | my $r = $db->db_readwrite($dbh, qq~ | |
| 157 | SELECT is_super_admin FROM `${DB}`.users WHERE id='$uid' LIMIT 1 | |
| 158 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 159 | $db->db_disconnect($dbh); | |
| 160 | ||
| 161 | my $flag = ($r && $r->{is_super_admin}) ? 1 : 0; | |
| 162 | $userinfo->{_super_admin} = $flag; | |
| 163 | return $flag; | |
| 164 | } | |
| 165 | ||
| 166 | #---------------------------------------------------------------------- | |
| 167 | # require_super_admin($userinfo, [$redirect_to]) | |
| 168 | # | |
| 169 | # Page-entry guard for the Software Configuration surface and any | |
| 170 | # other "platform owner only" controls. Bounces non-super-admins to | |
| 171 | # /admin.cgi with a denied marker. Impersonation does NOT pass through | |
| 172 | # here -- a regular admin acting as the super-admin still can't edit | |
| 173 | # platform secrets. | |
| 174 | #---------------------------------------------------------------------- | |
| 175 | sub require_super_admin { | |
| 176 | my ($self, $userinfo, $redirect_to) = @_; | |
| 177 | return if $self->is_super_admin($userinfo); | |
| 178 | $redirect_to ||= '/admin.cgi?denied=super_admin'; | |
| 179 | print "Status: 302 Found\nLocation: $redirect_to\n\n"; | |
| 180 | exit; | |
| 181 | } | |
| 182 | ||
| 183 | #---------------------------------------------------------------------- | |
| 184 | # Returns ($csv, $slug_map) for this $userinfo. Hydrates from DB on | |
| 185 | # first call and stashes on $userinfo so subsequent calls don't query. | |
| 186 | # | |
| 187 | # For owners returns (undef, {}). Callers should check the | |
| 188 | # permission_groups_id before calling -- this method assumes a team | |
| 189 | # member context. | |
| 190 | #---------------------------------------------------------------------- | |
| 191 | sub _load_cached { | |
| 192 | my ($self, $userinfo) = @_; | |
| 193 | ||
| 194 | if (exists $userinfo->{_perm_features_csv}) { | |
| 195 | return ($userinfo->{_perm_features_csv}, $userinfo->{_perm_slug_to_id} || {}); | |
| 196 | } | |
| 197 | ||
| 198 | my $pg = $userinfo->{permission_groups_id}; | |
| 199 | return (undef, {}) unless $pg; | |
| 200 | ||
| 201 | my $safe_pg = $pg; | |
| 202 | $safe_pg =~ s/[^0-9]//g; | |
| 203 | return (undef, {}) unless $safe_pg; | |
| 204 | ||
| 205 | my $dbh = $db->db_connect(); | |
| 206 | return (undef, {}) unless $dbh; | |
| 207 | ||
| 208 | # Pull the CSV for this user's group + the full slug->id map in | |
| 209 | # one trip. The slug map is global (not per-user) so caching it on | |
| 210 | # $userinfo is fine -- it's also tiny (28 rows today). | |
| 211 | my $row = $db->db_readwrite($dbh, qq~ | |
| 212 | SELECT permission_features_ids FROM `${DB}`.permission_groups | |
| 213 | WHERE id='$safe_pg' AND group_status=1 LIMIT 1 | |
| 214 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 215 | my $csv = ($row && defined $row->{permission_features_ids}) | |
| 216 | ? $row->{permission_features_ids} : ''; | |
| 217 | ||
| 218 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 219 | SELECT id, slug FROM `${DB}`.permission_features | |
| 220 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 221 | my %map; | |
| 222 | foreach my $r (@rows) { $map{$r->{slug}} = $r->{id}; } | |
| 223 | ||
| 224 | $db->db_disconnect($dbh); | |
| 225 | ||
| 226 | $userinfo->{_perm_features_csv} = $csv; | |
| 227 | $userinfo->{_perm_slug_to_id} = \%map; | |
| 228 | return ($csv, \%map); | |
| 229 | } | |
| 230 | ||
| 231 | 1; |