added on WebSTLs (webstls.com) at 2026-07-01 22:26:43
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # WebSTLs - Optimization | |
| 4 | # | |
| 5 | # Page body lives in TEMPLATES/webstls_optimization.html. | |
| 6 | # | |
| 7 | # ?new=1 show the New-experiment builder form instead of dashboard | |
| 8 | # (no arg) show the dashboard with the user's real experiments | |
| 9 | #====================================================================== | |
| 10 | use strict; | |
| 11 | use warnings; | |
| 12 | ||
| 13 | use lib '/var/www/vhosts/webstls.com/httpdocs'; | |
| 14 | use CGI; | |
| 15 | use MODS::Template; | |
| 16 | use MODS::DBConnect; | |
| 17 | use MODS::Login; | |
| 18 | use MODS::WebSTLs::Config; | |
| 19 | use MODS::WebSTLs::Wrapper; | |
| 20 | use MODS::WebSTLs::Experiments; | |
| 21 | use MODS::WebSTLs::PricingExperiments; | |
| 22 | use MODS::WebSTLs::Layouts; | |
| 23 | use MODS::WebSTLs::Themes; | |
| 24 | ||
| 25 | my $q = CGI->new; | |
| 26 | my $form = $q->Vars; | |
| 27 | my $auth = MODS::Login->new; | |
| 28 | my $wrap = MODS::WebSTLs::Wrapper->new; | |
| 29 | my $tfile = MODS::Template->new; | |
| 30 | my $db = MODS::DBConnect->new; | |
| 31 | my $cfg = MODS::WebSTLs::Config->new; | |
| 32 | my $DB = $cfg->settings('database_name'); | |
| 33 | ||
| 34 | $|=1; | |
| 35 | my $userinfo = $auth->login_verify(); | |
| 36 | if (!$userinfo) { | |
| 37 | print "Status: 302 Found\nLocation: /login.cgi\n\n"; | |
| 38 | exit; | |
| 39 | } | |
| 40 | require MODS::WebSTLs::Permissions; | |
| 41 | MODS::WebSTLs::Permissions->new->require_feature($userinfo, 'view_reports'); | |
| 42 | my $uid = $userinfo->{user_id}; | |
| 43 | $uid =~ s/[^0-9]//g; | |
| 44 | ||
| 45 | my $entry = ($ENV{SCRIPT_NAME} || '') =~ m{/([^/]+)\.cgi$} ? $1 : 'optimization'; | |
| 46 | ||
| 47 | if ($entry eq 'optimization_action') { | |
| 48 | _handle_action($q, $form, $userinfo); | |
| 49 | exit; | |
| 50 | } | |
| 51 | ||
| 52 | # Tutorial mode: when ?tutorial=1 we paint sample experiments, price | |
| 53 | # tests, and recommendations so a brand-new account can see what the | |
| 54 | # Optimization suite looks like with activity. Same pattern as the | |
| 55 | # dashboard / analytics tutorials. | |
| 56 | my $tutorial_mode = ($form->{tutorial} && $form->{tutorial} eq '1') ? 1 : 0; | |
| 57 | ||
| 58 | my $detail_id = $form->{id} || 0; | |
| 59 | $detail_id =~ s/[^0-9]//g; | |
| 60 | my $edit_id = $form->{edit} || 0; | |
| 61 | $edit_id =~ s/[^0-9]//g; | |
| 62 | ||
| 63 | # Mode resolution: detail > edit > new > list. Edit is treated as a | |
| 64 | # variation of "new" -- same builder UI, but pre-populated. | |
| 65 | my $mode = | |
| 66 | $detail_id ? 'detail' : | |
| 67 | $edit_id ? 'new' : | |
| 68 | ($form->{new} && $form->{new} eq '1') ? 'new' : 'list'; | |
| 69 | ||
| 70 | # ---- Pull the user's experiments (ab_tests JOIN storefronts) --------- | |
| 71 | # Guarded against the surface column not existing yet on a stale DB. | |
| 72 | my @experiments; | |
| 73 | my $dbh = $db->db_connect(); | |
| 74 | ||
| 75 | my $has_tbl = $db->db_readwrite($dbh, qq~ | |
| 76 | SELECT COUNT(*) AS n FROM information_schema.tables | |
| 77 | WHERE table_schema='$DB' AND table_name='ab_tests' | |
| 78 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 79 | ||
| 80 | my $has_surface = 0; | |
| 81 | if ($has_tbl && $has_tbl->{n}) { | |
| 82 | my $col = $db->db_readwrite($dbh, qq~ | |
| 83 | SELECT COUNT(*) AS n FROM information_schema.columns | |
| 84 | WHERE table_schema='$DB' AND table_name='ab_tests' AND column_name='surface' | |
| 85 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 86 | $has_surface = ($col && $col->{n}) ? 1 : 0; | |
| 87 | ||
| 88 | my $surface_sql = $has_surface ? 'ab.surface,' : "'' AS surface,"; | |
| 89 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 90 | SELECT ab.id, ab.name, ab.test_type, $surface_sql | |
| 91 | ab.status, ab.confidence_score, ab.traffic_seen, | |
| 92 | ab.start_date, ab.created_at, | |
| 93 | s.name AS storefront_name | |
| 94 | FROM `${DB}`.ab_tests ab | |
| 95 | JOIN `${DB}`.storefronts s ON s.id = ab.storefront_id | |
| 96 | WHERE s.user_id = '$uid' | |
| 97 | ORDER BY ab.created_at DESC | |
| 98 | LIMIT 50 | |
| 99 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 100 | ||
| 101 | # Bayesian stats: for every experiment row we recompute confidence | |
| 102 | # from ab_test_events on the fly. Cheap because the visitor counts | |
| 103 | # are COUNT(DISTINCT visitor_hash) on indexed columns. | |
| 104 | my $exh = MODS::WebSTLs::Experiments->new; | |
| 105 | ||
| 106 | foreach my $r (@rows) { | |
| 107 | my $status = $r->{status} || 'draft'; | |
| 108 | ||
| 109 | my $stats = ($status eq 'running' || $status eq 'paused' || $status eq 'complete') | |
| 110 | ? $exh->compute_stats($db, $dbh, $DB, $r->{id}) | |
| 111 | : {}; | |
| 112 | ||
| 113 | my $conf_display = '-'; | |
| 114 | my $lift_display = '-'; | |
| 115 | my $traffic = $r->{traffic_seen} || 0; | |
| 116 | if ($stats && %$stats) { | |
| 117 | $traffic = $stats->{traffic_seen} || 0; | |
| 118 | $conf_display = sprintf('%.1f%%', ($stats->{confidence} || 0) * 100); | |
| 119 | my $lift = $stats->{lift_pct} || 0; | |
| 120 | $lift_display = ($lift >= 0 ? '+' : '') . sprintf('%.1f%%', $lift); | |
| 121 | } | |
| 122 | ||
| 123 | # Current leader (used in the Complete confirm dialog so the | |
| 124 | # user can see which variant will get locked in). Ties go to | |
| 125 | # the control, matching the rule in optimization_action.cgi. | |
| 126 | my $rate_a = $stats->{rate_a} || 0; | |
| 127 | my $rate_b = $stats->{rate_b} || 0; | |
| 128 | my $leader_label = ($rate_b > $rate_a) ? 'B' : 'A'; | |
| 129 | my $leader_rate = ($rate_b > $rate_a) ? $rate_b : $rate_a; | |
| 130 | my $has_any_data = (($stats->{exposures_a} || 0) + ($stats->{exposures_b} || 0)) > 0 ? 1 : 0; | |
| 131 | my $leader_rate_pct = sprintf('%.2f%%', $leader_rate * 100); | |
| 132 | ||
| 133 | # Pre-render the Complete confirm() text. Must avoid apostrophes | |
| 134 | # because the string is dropped into a single-quoted JS string | |
| 135 | # in an HTML onsubmit attribute. Using "is" / "no" wording | |
| 136 | # instead of "is not" / "does not" keeps everything safe. | |
| 137 | my $complete_confirm = | |
| 138 | $has_any_data | |
| 139 | ? "Mark this experiment complete? Based on current data, Variant ${leader_label} is winning at ${leader_rate_pct} conversion. Marking complete locks in Variant ${leader_label} as the winner, stops bucketing new visitors, and moves the test to the Completed section." | |
| 140 | : "Mark this experiment complete? No visitors have been bucketed yet so the control (Variant A) will be locked in as the winner by default. You can Re-run the test from the Completed section once you want fresh data."; | |
| 141 | ||
| 142 | push @experiments, { | |
| 143 | id => $r->{id}, | |
| 144 | name => _h($r->{name}), | |
| 145 | test_type => uc($r->{test_type} || 'AB'), | |
| 146 | surface => $r->{surface} || '', | |
| 147 | status => $status, | |
| 148 | status_label => ucfirst($status), | |
| 149 | is_draft => $status eq 'draft' ? 1 : 0, | |
| 150 | is_running => $status eq 'running' ? 1 : 0, | |
| 151 | is_paused => $status eq 'paused' ? 1 : 0, | |
| 152 | is_complete => $status eq 'complete' ? 1 : 0, | |
| 153 | is_aborted => $status eq 'aborted' ? 1 : 0, | |
| 154 | confidence => $conf_display, | |
| 155 | lift => $lift_display, | |
| 156 | traffic_seen => $traffic, | |
| 157 | storefront => _h($r->{storefront_name} || ''), | |
| 158 | created_at => $r->{created_at} || '', | |
| 159 | # Leader info for the Complete confirm dialog. | |
| 160 | leader_label => $leader_label, | |
| 161 | leader_rate => $leader_rate_pct, | |
| 162 | has_any_data => $has_any_data, | |
| 163 | complete_confirm => $complete_confirm, | |
| 164 | }; | |
| 165 | } | |
| 166 | } | |
| 167 | ||
| 168 | # Get the user's primary storefront so the builder can default to it. | |
| 169 | my $sf = $db->db_readwrite($dbh, | |
| 170 | qq~SELECT id, name FROM `${DB}`.storefronts WHERE user_id='$uid' ORDER BY id LIMIT 1~, | |
| 171 | $ENV{SCRIPT_NAME}, __LINE__); | |
| 172 | my $store_id = ($sf && $sf->{id}) ? $sf->{id} : 0; | |
| 173 | my $store_name = ($sf && $sf->{name}) ? $sf->{name} : ''; | |
| 174 | ||
| 175 | # Re-derive the surface-column existence flag here so it is in scope | |
| 176 | # for the edit/detail loaders below (the listing block defines it | |
| 177 | # locally; we hoist it out for re-use). | |
| 178 | unless (defined $has_surface) { | |
| 179 | my $col2 = $db->db_readwrite($dbh, qq~ | |
| 180 | SELECT COUNT(*) AS n FROM information_schema.columns | |
| 181 | WHERE table_schema='$DB' AND table_name='ab_tests' AND column_name='surface' | |
| 182 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 183 | $has_surface = ($col2 && $col2->{n}) ? 1 : 0; | |
| 184 | } | |
| 185 | ||
| 186 | # Forward-declared lookup lists used by BOTH the edit/detail block | |
| 187 | # (which mirrors has_custom_themes into each variant) and the builder's | |
| 188 | # new-experiment form. Populated once below when $mode eq 'new'; the | |
| 189 | # edit/detail path only needs the scalar size. | |
| 190 | my @user_models; | |
| 191 | my @layout_options; | |
| 192 | my @theme_options; | |
| 193 | my @custom_theme_options; | |
| 194 | ||
| 195 | # Load a single experiment row for edit + detail modes. Ownership is | |
| 196 | # enforced via the storefront JOIN; if the row does not belong to this | |
| 197 | # user, $edit_row stays empty and the templates fall back gracefully. | |
| 198 | my %edit_row; | |
| 199 | my %detail_row; | |
| 200 | my @detail_variants; | |
| 201 | my %detail_stats; | |
| 202 | if ($edit_id || $detail_id) { | |
| 203 | my $target_id = $edit_id || $detail_id; | |
| 204 | my $surface_sql_pick = $has_surface ? 'ab.surface' : "'' AS surface"; | |
| 205 | my $r = $db->db_readwrite($dbh, qq~ | |
| 206 | SELECT ab.id, ab.name, ab.test_type, $surface_sql_pick, | |
| 207 | ab.status, ab.primary_metric, ab.variants, | |
| 208 | ab.winner_variant_id, ab.confidence_score, | |
| 209 | ab.start_date, ab.end_date, ab.created_at, | |
| 210 | s.id AS storefront_id | |
| 211 | FROM `${DB}`.ab_tests ab | |
| 212 | JOIN `${DB}`.storefronts s ON s.id = ab.storefront_id | |
| 213 | WHERE ab.id='$target_id' AND s.user_id='$uid' | |
| 214 | LIMIT 1 | |
| 215 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 216 | ||
| 217 | if ($r && $r->{id}) { | |
| 218 | # Parse out every variant for the edit form (up to 6: A-F). | |
| 219 | my @vs = _parse_variants_for_edit($r->{variants} || ''); | |
| 220 | ||
| 221 | %edit_row = ( | |
| 222 | id => $r->{id}, | |
| 223 | name => _h($r->{name}), | |
| 224 | test_type => $r->{test_type} || 'ab', | |
| 225 | surface => $r->{surface} || 'hero_title', | |
| 226 | primary_metric => $r->{primary_metric} || 'conversion_rate', | |
| 227 | target_model_id => ( | |
| 228 | ($vs[0] && $vs[0]->{target_model_id}) || | |
| 229 | ($vs[1] && $vs[1]->{target_model_id}) || 0 | |
| 230 | ), | |
| 231 | edit_variant_count => scalar(@vs) || 2, | |
| 232 | ); | |
| 233 | ||
| 234 | # Build the per-variant edit fields. We always render 2 rows | |
| 235 | # (A control + B challenger) and additionally render C..F when | |
| 236 | # the saved JSON carried them. The template iterates a single | |
| 237 | # loop over edit_variants to keep the markup uniform. | |
| 238 | my @LETTERS = ('A', 'B', 'C', 'D', 'E', 'F'); | |
| 239 | my @edit_variants; | |
| 240 | my $n_render = scalar(@vs); | |
| 241 | $n_render = 2 if $n_render < 2; | |
| 242 | $n_render = 6 if $n_render > 6; | |
| 243 | for (my $i = 0; $i < $n_render; $i++) { | |
| 244 | my $v = $vs[$i] || {}; | |
| 245 | my $vid = $LETTERS[$i]; | |
| 246 | my $is_control = ($i == 0) ? 1 : 0; | |
| 247 | push @edit_variants, { | |
| 248 | vid => $vid, | |
| 249 | vid_lc => lc($vid), | |
| 250 | label => $is_control | |
| 251 | ? "Variant $vid . Control" | |
| 252 | : "Variant $vid . Challenger", | |
| 253 | is_control => $is_control, | |
| 254 | name => _h($v->{name} // ''), | |
| 255 | text => _h($v->{text} // ''), | |
| 256 | image_url => $v->{image_url} // '', | |
| 257 | has_image => $v->{image_url} ? 1 : 0, | |
| 258 | layout_id => ($v->{layout_id} || 0) + 0, | |
| 259 | theme_id => ($v->{theme_id} || 0) + 0, | |
| 260 | custom_theme_id => ($v->{custom_theme_id} || 0) + 0, | |
| 261 | # Pre-baked form field names. The template engine's | |
| 262 | # greedy \w+ parsing means $loop1.vid_text would look up | |
| 263 | # key "vid_text" (not concatenate). Pre-compute the full | |
| 264 | # names here so the template can just emit them. | |
| 265 | name_field => "variant_${vid}_name", | |
| 266 | text_field => "variant_${vid}_text", | |
| 267 | image_field => "variant_${vid}_image", | |
| 268 | image_existing_field => "variant_${vid}_image_existing", | |
| 269 | layout_id_field => "variant_${vid}_layout_id", | |
| 270 | theme_id_field => "variant_${vid}_theme_id", | |
| 271 | custom_theme_id_field => "variant_${vid}_custom_theme_id", | |
| 272 | # Mirror top-level tvars into each row so [if:] tests | |
| 273 | # work inside the loop (engine resolves bare $foo against | |
| 274 | # the current $loopN row, not the outer tvars). | |
| 275 | has_custom_themes => scalar(@custom_theme_options) ? 1 : 0, | |
| 276 | }; | |
| 277 | } | |
| 278 | $edit_row{edit_variants} = \@edit_variants; | |
| 279 | ||
| 280 | # Detail view: per-variant stats. | |
| 281 | if ($detail_id) { | |
| 282 | require MODS::WebSTLs::Experiments; | |
| 283 | my $exh = MODS::WebSTLs::Experiments->new; | |
| 284 | my $stats = $exh->compute_stats($db, $dbh, $DB, $r->{id}) || {}; | |
| 285 | ||
| 286 | %detail_row = ( | |
| 287 | id => $r->{id}, | |
| 288 | name => _h($r->{name}), | |
| 289 | test_type => uc($r->{test_type} || 'AB'), | |
| 290 | surface => $r->{surface} || '', | |
| 291 | status => $r->{status} || 'draft', | |
| 292 | primary_metric => $r->{primary_metric} || 'conversion_rate', | |
| 293 | created_at => $r->{created_at} || '', | |
| 294 | start_date => $r->{start_date} || '-', | |
| 295 | ); | |
| 296 | $detail_row{is_running} = $detail_row{status} eq 'running' ? 1 : 0; | |
| 297 | $detail_row{is_draft} = $detail_row{status} eq 'draft' ? 1 : 0; | |
| 298 | $detail_row{is_paused} = $detail_row{status} eq 'paused' ? 1 : 0; | |
| 299 | $detail_row{is_complete} = $detail_row{status} eq 'complete' ? 1 : 0; | |
| 300 | ||
| 301 | my $exp_a = $stats->{exposures_a} || 0; | |
| 302 | my $exp_b = $stats->{exposures_b} || 0; | |
| 303 | my $conv_a = $stats->{conversions_a} || 0; | |
| 304 | my $conv_b = $stats->{conversions_b} || 0; | |
| 305 | my $rate_a = $stats->{rate_a} || 0; | |
| 306 | my $rate_b = $stats->{rate_b} || 0; | |
| 307 | my $lift = $stats->{lift_pct} || 0; | |
| 308 | my $conf = $stats->{confidence} || 0; | |
| 309 | ||
| 310 | $detail_row{traffic_seen} = $stats->{traffic_seen} || 0; | |
| 311 | $detail_row{has_stats} = ($exp_a + $exp_b) ? 1 : 0; | |
| 312 | $detail_row{conf_pct} = sprintf('%.1f%%', $conf * 100); | |
| 313 | $detail_row{conf_raw} = $conf; | |
| 314 | $detail_row{lift_pct} = ($lift >= 0 ? '+' : '') . sprintf('%.1f%%', $lift); | |
| 315 | $detail_row{lift_raw} = $lift; | |
| 316 | ||
| 317 | # Winner state: above threshold = call winner; ramping up | |
| 318 | # otherwise; insufficient data when fewer than ~50 per arm. | |
| 319 | my $threshold = 0.95; | |
| 320 | $detail_row{below_min_sample} = ($exp_a < 25 || $exp_b < 25) ? 1 : 0; | |
| 321 | $detail_row{winner_called} = (!$detail_row{below_min_sample} && $conf >= $threshold) ? 1 : 0; | |
| 322 | $detail_row{too_early} = (!$detail_row{below_min_sample} && !$detail_row{winner_called}) ? 1 : 0; | |
| 323 | ||
| 324 | # Why-is-it-winning narrative. | |
| 325 | my $w_label = $rate_b > $rate_a ? 'B' : 'A'; | |
| 326 | my $w_rate = $rate_b > $rate_a ? $rate_b : $rate_a; | |
| 327 | my $l_rate = $rate_b > $rate_a ? $rate_a : $rate_b; | |
| 328 | my $w_pct = sprintf('%.2f%%', $w_rate * 100); | |
| 329 | my $l_pct = sprintf('%.2f%%', $l_rate * 100); | |
| 330 | $detail_row{leader_label} = $w_label; | |
| 331 | $detail_row{leader_rate} = $w_pct; | |
| 332 | $detail_row{loser_rate} = $l_pct; | |
| 333 | ||
| 334 | # If the test has already been Completed, the winner is | |
| 335 | # locked in the row's winner_variant_id. Surface it so the | |
| 336 | # detail page can display the final pick prominently. | |
| 337 | my $locked = $r->{winner_variant_id} || ''; | |
| 338 | $locked =~ s/[^A-Za-z0-9_\-]//g; | |
| 339 | $detail_row{has_locked_winner} = ($locked && $detail_row{is_complete}) ? 1 : 0; | |
| 340 | $detail_row{locked_winner_id} = $locked; | |
| 341 | $detail_row{has_any_data} = ($exp_a + $exp_b) ? 1 : 0; | |
| 342 | ||
| 343 | # Pre-render the Complete confirm() text for the detail | |
| 344 | # action bar -- same format as the list rows. | |
| 345 | my $w_lbl = $detail_row{leader_label}; | |
| 346 | $detail_row{complete_confirm} = ($exp_a + $exp_b) | |
| 347 | ? "Mark this experiment complete? Based on current data, Variant ${w_lbl} is winning at ${w_pct} conversion. Marking complete locks in Variant ${w_lbl} as the winner, stops bucketing new visitors, and moves the test to the Completed section." | |
| 348 | : "Mark this experiment complete? No visitors have been bucketed yet so the control (Variant A) will be locked in as the winner by default. You can Re-run the test from the Completed section once you want fresh data."; | |
| 349 | ||
| 350 | # Variant cards. | |
| 351 | my $primary_metric_label = | |
| 352 | $detail_row{primary_metric} eq 'conversion_rate' ? 'purchases' : | |
| 353 | $detail_row{primary_metric} eq 'add_to_cart' ? 'add to carts' : | |
| 354 | $detail_row{primary_metric} eq 'click' ? 'clicks' : | |
| 355 | $detail_row{primary_metric} eq 'signup' ? 'signups' : | |
| 356 | 'conversions'; | |
| 357 | $detail_row{metric_label} = $primary_metric_label; | |
| 358 | ||
| 359 | # Per-variant per-event-type counts so MVT tests with 3+ | |
| 360 | # variants can still render their cards with real exposure | |
| 361 | # + conversion numbers (the rate_a / rate_b returned by | |
| 362 | # compute_stats only covers the leader pair). | |
| 363 | my $conv_event_for_metric = | |
| 364 | $detail_row{primary_metric} eq 'add_to_cart' ? 'add_to_cart' : | |
| 365 | $detail_row{primary_metric} eq 'click' ? 'click' : | |
| 366 | $detail_row{primary_metric} eq 'signup' ? 'custom' : | |
| 367 | 'purchase'; | |
| 368 | my %expo_by; | |
| 369 | my %conv_by; | |
| 370 | my @e_rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 371 | SELECT variant_id, COUNT(DISTINCT visitor_hash) AS n | |
| 372 | FROM `${DB}`.ab_test_events | |
| 373 | WHERE ab_test_id='$r->{id}' AND event_type='exposure' | |
| 374 | GROUP BY variant_id | |
| 375 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 376 | $expo_by{$_->{variant_id}} = $_->{n} for @e_rows; | |
| 377 | my @c_rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 378 | SELECT variant_id, COUNT(DISTINCT visitor_hash) AS n | |
| 379 | FROM `${DB}`.ab_test_events | |
| 380 | WHERE ab_test_id='$r->{id}' AND event_type='$conv_event_for_metric' | |
| 381 | GROUP BY variant_id | |
| 382 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 383 | $conv_by{$_->{variant_id}} = $_->{n} for @c_rows; | |
| 384 | ||
| 385 | # Highest conversion rate among variants -> "is_leader" | |
| 386 | # styling on that card. | |
| 387 | my %rate_by; | |
| 388 | foreach my $v (@vs) { | |
| 389 | my $vid = $v->{id} || ''; | |
| 390 | my $e = $expo_by{$vid} || 0; | |
| 391 | my $c = $conv_by{$vid} || 0; | |
| 392 | $rate_by{$vid} = $e ? ($c / $e) : 0; | |
| 393 | } | |
| 394 | my $leader_vid = ''; | |
| 395 | my $leader_r = -1; | |
| 396 | foreach my $vid (keys %rate_by) { | |
| 397 | if ($rate_by{$vid} > $leader_r) { | |
| 398 | $leader_r = $rate_by{$vid}; | |
| 399 | $leader_vid = $vid; | |
| 400 | } | |
| 401 | } | |
| 402 | ||
| 403 | # Helper objects so we can resolve layout / theme ids back to | |
| 404 | # display names for the detail cards. | |
| 405 | my $layouts_h = MODS::WebSTLs::Layouts->new; | |
| 406 | my $themes_h = MODS::WebSTLs::Themes->new; | |
| 407 | ||
| 408 | foreach my $v (@vs) { | |
| 409 | my $vid = $v->{id} || ''; | |
| 410 | my $e = $expo_by{$vid} || 0; | |
| 411 | my $c = $conv_by{$vid} || 0; | |
| 412 | my $rt = $rate_by{$vid} || 0; | |
| 413 | my $is_control = ($vid eq ($vs[0]->{id} || 'A')) ? 1 : 0; | |
| 414 | ||
| 415 | my $lid = ($v->{layout_id} || 0) + 0; | |
| 416 | my $tid = ($v->{theme_id} || 0) + 0; | |
| 417 | my $ctid = ($v->{custom_theme_id} || 0) + 0; | |
| 418 | my $layout_name = ''; | |
| 419 | my $theme_name = ''; | |
| 420 | if ($lid) { | |
| 421 | my $L = $layouts_h->by_id($lid); | |
| 422 | $layout_name = $L->{name} if $L && $L->{name}; | |
| 423 | } | |
| 424 | if ($ctid) { | |
| 425 | my $ct = $themes_h->custom_by_id($db, $dbh, $DB, $ctid); | |
| 426 | $theme_name = ($ct && $ct->{name}) ? $ct->{name} : ''; | |
| 427 | } elsif ($tid) { | |
| 428 | my $T = $themes_h->by_id($tid); | |
| 429 | $theme_name = $T->{name} if $T && $T->{name}; | |
| 430 | } | |
| 431 | ||
| 432 | # Is this experiment a design-surface test? Used so the | |
| 433 | # template can render an explicit "inherits storefront's | |
| 434 | # saved layout/theme" panel on the control card instead | |
| 435 | # of falling through to the generic "no image" placeholder. | |
| 436 | my $is_design_test = | |
| 437 | ($detail_row{surface} eq 'layout' | |
| 438 | || $detail_row{surface} eq 'theme' | |
| 439 | || $detail_row{surface} eq 'layout_and_theme') ? 1 : 0; | |
| 440 | my $show_layout_inherit = | |
| 441 | $is_design_test | |
| 442 | && !$lid | |
| 443 | && ($detail_row{surface} eq 'layout' | |
| 444 | || $detail_row{surface} eq 'layout_and_theme'); | |
| 445 | my $show_theme_inherit = | |
| 446 | $is_design_test | |
| 447 | && !$tid && !$ctid | |
| 448 | && ($detail_row{surface} eq 'theme' | |
| 449 | || $detail_row{surface} eq 'layout_and_theme'); | |
| 450 | ||
| 451 | push @detail_variants, { | |
| 452 | id => $vid, | |
| 453 | label => 'Variant ' . $vid . ' . ' | |
| 454 | . ($is_control ? 'Control' : 'Challenger'), | |
| 455 | text => _h($v->{text} || '(unchanged)'), | |
| 456 | image_url => $v->{image_url} || '', | |
| 457 | has_image => $v->{image_url} ? 1 : 0, | |
| 458 | layout_id => $lid, | |
| 459 | theme_id => $tid, | |
| 460 | custom_theme_id => $ctid, | |
| 461 | layout_name => _h($layout_name), | |
| 462 | theme_name => _h($theme_name), | |
| 463 | has_design => ($lid || $tid || $ctid || $is_design_test) ? 1 : 0, | |
| 464 | has_layout_pick => $lid ? 1 : 0, | |
| 465 | has_theme_pick => ($tid || $ctid) ? 1 : 0, | |
| 466 | show_layout_inherit => $show_layout_inherit ? 1 : 0, | |
| 467 | show_theme_inherit => $show_theme_inherit ? 1 : 0, | |
| 468 | exposures => $e, | |
| 469 | conversions => $c, | |
| 470 | rate => sprintf('%.2f%%', $rt * 100), | |
| 471 | is_leader => ($vid eq $leader_vid && $e > 0) ? 1 : 0, | |
| 472 | is_locked_winner => ($detail_row{has_locked_winner} | |
| 473 | && $detail_row{locked_winner_id} eq $vid) ? 1 : 0, | |
| 474 | }; | |
| 475 | } | |
| 476 | } | |
| 477 | } | |
| 478 | elsif ($detail_id || $edit_id) { | |
| 479 | # Row not owned / not found -- bounce back to the list. | |
| 480 | $db->db_disconnect($dbh); | |
| 481 | print "Status: 302 Found\nLocation: /optimization.cgi\n\n"; | |
| 482 | exit; | |
| 483 | } | |
| 484 | } | |
| 485 | ||
| 486 | # Load the user's published models. Needed by: | |
| 487 | # - mode=new : the experiment builder's "Product to test" dropdown | |
| 488 | # - mode=list: the Price tests / Surveys "Pick a model" dropdowns | |
| 489 | # (previously gated to mode=new which left those empty) | |
| 490 | # Layout / theme pickers are only needed by the builder, so they stay | |
| 491 | # gated to mode=new. | |
| 492 | if ($mode eq 'new' || $mode eq 'list') { | |
| 493 | @user_models = $db->db_readwrite_multiple($dbh, qq~ | |
| 494 | SELECT id, title | |
| 495 | FROM `${DB}`.models | |
| 496 | WHERE user_id='$uid' | |
| 497 | AND purged_at IS NULL | |
| 498 | AND status='published' | |
| 499 | ORDER BY updated_at DESC | |
| 500 | LIMIT 100 | |
| 501 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 502 | foreach my $m (@user_models) { | |
| 503 | $m->{title} = _h($m->{title} || ('Model #' . $m->{id})); | |
| 504 | } | |
| 505 | } | |
| 506 | ||
| 507 | if ($mode eq 'new') { | |
| 508 | # Layout picker options (used by surface=layout / layout_and_theme). | |
| 509 | my $layouts_helper = MODS::WebSTLs::Layouts->new; | |
| 510 | foreach my $L (@{ $layouts_helper->all }) { | |
| 511 | push @layout_options, { | |
| 512 | id => $L->{id}, | |
| 513 | name => _h($L->{name} || ('Layout ' . $L->{id})), | |
| 514 | tagline => _h($L->{tagline} || ''), | |
| 515 | }; | |
| 516 | } | |
| 517 | ||
| 518 | # Built-in theme picker options. | |
| 519 | my $themes_helper = MODS::WebSTLs::Themes->new; | |
| 520 | foreach my $T (@{ $themes_helper->all }) { | |
| 521 | push @theme_options, { | |
| 522 | id => $T->{id}, | |
| 523 | name => _h($T->{name} || ('Theme ' . $T->{id})), | |
| 524 | }; | |
| 525 | } | |
| 526 | ||
| 527 | # The seller's saved custom themes for THIS user's storefronts. | |
| 528 | # Joined to storefronts so we only show themes the seller actually | |
| 529 | # owns. Distinct names because a theme is tied to one storefront. | |
| 530 | if ($store_id) { | |
| 531 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 532 | SELECT id, name | |
| 533 | FROM `${DB}`.storefront_custom_themes | |
| 534 | WHERE storefront_id='$store_id' | |
| 535 | ORDER BY updated_at DESC | |
| 536 | LIMIT 50 | |
| 537 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 538 | foreach my $ct (@rows) { | |
| 539 | push @custom_theme_options, { | |
| 540 | id => $ct->{id}, | |
| 541 | name => _h($ct->{name} || ('Custom theme #' . $ct->{id})), | |
| 542 | }; | |
| 543 | } | |
| 544 | } | |
| 545 | } | |
| 546 | ||
| 547 | # Price tests + Van Westendorp surveys -- the previously "coming soon" | |
| 548 | # section. Same render template; just extra tvars driving real rows. | |
| 549 | my $px = MODS::WebSTLs::PricingExperiments->new; | |
| 550 | my $px_ready = $px->schema_ready($db, $dbh, $DB); | |
| 551 | my @price_tests = $px_ready ? $px->list_user_price_tests($db, $dbh, $DB, $uid) : (); | |
| 552 | my @surveys = $px_ready ? $px->list_user_surveys($db, $dbh, $DB, $uid) : (); | |
| 553 | ||
| 554 | # Optional: when the seller navigates to ?survey_results=N we render | |
| 555 | # the aggregated VW intersection points for that one survey on this | |
| 556 | # page (no separate page). Caller-scoped via PricingExperiments which | |
| 557 | # does the ownership check. | |
| 558 | my $survey_results_id = $form->{survey_results} || 0; | |
| 559 | $survey_results_id =~ s/[^0-9]//g; | |
| 560 | my %survey_results; | |
| 561 | if ($survey_results_id && $px_ready) { | |
| 562 | my $r = $px->survey_results($db, $dbh, $DB, $uid, $survey_results_id); | |
| 563 | if ($r && $r->{ok}) { %survey_results = %$r; } | |
| 564 | } | |
| 565 | ||
| 566 | # Format price-test rows for the template. | |
| 567 | my @test_rows; | |
| 568 | foreach my $t (@price_tests) { | |
| 569 | my $rules = $t->{test_rules} || ''; | |
| 570 | my ($min_c, $max_c, $step_c) = (0, 0, 100); | |
| 571 | if ($rules =~ /"min":\s*(\d+)/) { $min_c = $1; } | |
| 572 | if ($rules =~ /"max":\s*(\d+)/) { $max_c = $1; } | |
| 573 | if ($rules =~ /"step":\s*(\d+)/) { $step_c = $1; } | |
| 574 | push @test_rows, { | |
| 575 | id => $t->{id}, | |
| 576 | model_title => _h($t->{model_title} || ('Model #' . $t->{model_id})), | |
| 577 | current_display => '$' . sprintf('%.2f', ($t->{current_price_cents} || 0) / 100), | |
| 578 | min_display => '$' . sprintf('%.2f', $min_c / 100), | |
| 579 | max_display => '$' . sprintf('%.2f', $max_c / 100), | |
| 580 | step_display => '$' . sprintf('%.2f', $step_c / 100), | |
| 581 | status => $t->{status} || 'draft', | |
| 582 | status_label => ucfirst($t->{status} || 'draft'), | |
| 583 | is_draft => ($t->{status} || '') eq 'draft' ? 1 : 0, | |
| 584 | is_running => ($t->{status} || '') eq 'running' ? 1 : 0, | |
| 585 | is_paused => ($t->{status} || '') eq 'paused' ? 1 : 0, | |
| 586 | is_complete => ($t->{status} || '') eq 'complete' ? 1 : 0, | |
| 587 | }; | |
| 588 | } | |
| 589 | ||
| 590 | # Format survey rows. public_url is the absolute URL the seller will | |
| 591 | # share with respondents. | |
| 592 | my @survey_rows; | |
| 593 | my $proto = 'https'; | |
| 594 | $proto = 'http' unless ($ENV{HTTPS} || '') =~ /^on$/i | |
| 595 | || ($ENV{HTTP_X_FORWARDED_PROTO} || '') =~ /^https$/i; | |
| 596 | my $host = $ENV{HTTP_HOST} || 'webstls.com'; | |
| 597 | foreach my $s (@surveys) { | |
| 598 | push @survey_rows, { | |
| 599 | id => $s->{id}, | |
| 600 | model_title => _h($s->{model_title} || ('Model #' . $s->{model_id})), | |
| 601 | title => _h($s->{title} || 'Pricing survey'), | |
| 602 | public_url => "$proto://$host/price_survey.cgi?t=" . ($s->{public_token} || ''), | |
| 603 | response_count => $s->{response_count} || 0, | |
| 604 | status => $s->{status} || 'open', | |
| 605 | is_open => ($s->{status} || '') eq 'open' ? 1 : 0, | |
| 606 | is_closed => ($s->{status} || '') eq 'closed' ? 1 : 0, | |
| 607 | results_href => '/optimization.cgi?survey_results=' . $s->{id} . '#survey', | |
| 608 | }; | |
| 609 | } | |
| 610 | ||
| 611 | # Aggregated Van Westendorp intersections for the requested survey, | |
| 612 | # if any. Money formatting happens here so the template stays dumb. | |
| 613 | my %vw_display; | |
| 614 | if (%survey_results && $survey_results{n}) { | |
| 615 | %vw_display = ( | |
| 616 | vw_n => $survey_results{n}, | |
| 617 | vw_pmc => '$' . sprintf('%.2f', ($survey_results{pmc} || 0) / 100), | |
| 618 | vw_pme => '$' . sprintf('%.2f', ($survey_results{pme} || 0) / 100), | |
| 619 | vw_opp => '$' . sprintf('%.2f', ($survey_results{opp} || 0) / 100), | |
| 620 | vw_ipp => '$' . sprintf('%.2f', ($survey_results{ipp} || 0) / 100), | |
| 621 | ); | |
| 622 | } | |
| 623 | ||
| 624 | # Flash params from optimization_action.cgi. | |
| 625 | my $opt_flash_msg = ''; | |
| 626 | my $opt_flash_kind = ''; | |
| 627 | if (defined $form->{ok}) { | |
| 628 | my $k = $form->{ok}; $k =~ s/[^a-z_]//g; | |
| 629 | $opt_flash_kind = 'success'; | |
| 630 | $opt_flash_msg = 'test_created' eq $k ? 'Price test created (status: draft). Start it when you are ready.' | |
| 631 | : 'test_status' eq $k ? 'Price test status updated.' | |
| 632 | : 'test_deleted' eq $k ? 'Price test deleted.' | |
| 633 | : 'survey_created' eq $k ? 'Survey created. Share the URL below to start collecting responses.' | |
| 634 | : 'survey_closed' eq $k ? 'Survey closed -- no new responses will be accepted.' | |
| 635 | : 'survey_deleted' eq $k ? 'Survey deleted.' | |
| 636 | : 'Saved.'; | |
| 637 | } | |
| 638 | if (defined $form->{err}) { | |
| 639 | my $e = $form->{err}; $e =~ s/[^A-Za-z0-9 ._-]//g; $e = substr($e, 0, 120); | |
| 640 | $opt_flash_kind = 'danger'; | |
| 641 | $opt_flash_msg = $e eq 'denied' ? 'Permission denied.' | |
| 642 | : $e eq 'schema' ? 'Pricing-experiment tables are not migrated yet.' | |
| 643 | : 'Could not complete the action: ' . $e; | |
| 644 | } | |
| 645 | ||
| 646 | $db->db_disconnect($dbh); | |
| 647 | ||
| 648 | my $tvars = { | |
| 649 | user_id => $uid, | |
| 650 | mode_new => $mode eq 'new' ? 1 : 0, | |
| 651 | mode_list => $mode eq 'list' ? 1 : 0, | |
| 652 | mode_detail => $mode eq 'detail' ? 1 : 0, | |
| 653 | is_edit => $edit_id ? 1 : 0, | |
| 654 | edit_id => $edit_id || 0, | |
| 655 | has_storefront => $store_id ? 1 : 0, | |
| 656 | store_id => $store_id, | |
| 657 | store_name => _h($store_name), | |
| 658 | user_models => \@user_models, | |
| 659 | has_user_models => scalar(@user_models) ? 1 : 0, | |
| 660 | layout_options => \@layout_options, | |
| 661 | has_layout_options => scalar(@layout_options) ? 1 : 0, | |
| 662 | theme_options => \@theme_options, | |
| 663 | has_theme_options => scalar(@theme_options) ? 1 : 0, | |
| 664 | custom_theme_options => \@custom_theme_options, | |
| 665 | has_custom_themes => scalar(@custom_theme_options) ? 1 : 0, | |
| 666 | experiments => \@experiments, | |
| 667 | has_experiments => scalar(@experiments) ? 1 : 0, | |
| 668 | experiment_count => scalar(@experiments), | |
| 669 | # Split into three lifecycle buckets so the list view can show them | |
| 670 | # as separate sections: Active (draft/running/paused), Completed | |
| 671 | # (the test was called), Archived (aborted/parked). | |
| 672 | experiments_active => [ grep { $_->{is_draft} || $_->{is_running} || $_->{is_paused} } @experiments ], | |
| 673 | experiments_completed => [ grep { $_->{is_complete} } @experiments ], | |
| 674 | experiments_archived => [ grep { $_->{is_aborted} } @experiments ], | |
| 675 | has_active_experiments => (scalar(grep { $_->{is_draft} || $_->{is_running} || $_->{is_paused} } @experiments)) ? 1 : 0, | |
| 676 | has_completed_experiments => (scalar(grep { $_->{is_complete} } @experiments)) ? 1 : 0, | |
| 677 | has_archived_experiments => (scalar(grep { $_->{is_aborted} } @experiments)) ? 1 : 0, | |
| 678 | active_count => scalar(grep { $_->{is_draft} || $_->{is_running} || $_->{is_paused} } @experiments), | |
| 679 | completed_count => scalar(grep { $_->{is_complete} } @experiments), | |
| 680 | archived_count => scalar(grep { $_->{is_aborted} } @experiments), | |
| 681 | saved_flash => ($form->{saved} || '') eq '1' ? 1 : 0, | |
| 682 | ||
| 683 | # Edit-mode pre-population (empty strings when in create mode). | |
| 684 | edit_name => $edit_row{name} // '', | |
| 685 | edit_test_type => $edit_row{test_type} // '', | |
| 686 | edit_surface => $edit_row{surface} // '', | |
| 687 | edit_primary_metric => $edit_row{primary_metric} // '', | |
| 688 | edit_target_model_id => $edit_row{target_model_id} // 0, | |
| 689 | edit_variant_count => $edit_row{edit_variant_count} // 2, | |
| 690 | edit_variants => $edit_row{edit_variants} // [ | |
| 691 | { | |
| 692 | vid=>'A', vid_lc=>'a', label=>'Variant A . Control', | |
| 693 | is_control=>1, name=>'', text=>'', image_url=>'', | |
| 694 | has_image=>0, layout_id=>0, theme_id=>0, custom_theme_id=>0, | |
| 695 | name_field=>'variant_A_name', text_field=>'variant_A_text', | |
| 696 | image_field=>'variant_A_image', image_existing_field=>'variant_A_image_existing', | |
| 697 | layout_id_field=>'variant_A_layout_id', | |
| 698 | theme_id_field=>'variant_A_theme_id', | |
| 699 | custom_theme_id_field=>'variant_A_custom_theme_id', | |
| 700 | has_custom_themes => scalar(@custom_theme_options) ? 1 : 0, | |
| 701 | }, | |
| 702 | { | |
| 703 | vid=>'B', vid_lc=>'b', label=>'Variant B . Challenger', | |
| 704 | is_control=>0, name=>'', text=>'', image_url=>'', | |
| 705 | has_image=>0, layout_id=>0, theme_id=>0, custom_theme_id=>0, | |
| 706 | name_field=>'variant_B_name', text_field=>'variant_B_text', | |
| 707 | image_field=>'variant_B_image', image_existing_field=>'variant_B_image_existing', | |
| 708 | layout_id_field=>'variant_B_layout_id', | |
| 709 | theme_id_field=>'variant_B_theme_id', | |
| 710 | custom_theme_id_field=>'variant_B_custom_theme_id', | |
| 711 | has_custom_themes => scalar(@custom_theme_options) ? 1 : 0, | |
| 712 | }, | |
| 713 | ], | |
| 714 | ||
| 715 | # Detail-mode payload (empty/zero when not in detail mode). | |
| 716 | detail_id => $detail_row{id} // 0, | |
| 717 | detail_name => $detail_row{name} // '', | |
| 718 | detail_test_type => $detail_row{test_type} // '', | |
| 719 | detail_surface => $detail_row{surface} // '', | |
| 720 | detail_status => $detail_row{status} // '', | |
| 721 | detail_metric_label => $detail_row{metric_label} // 'conversions', | |
| 722 | detail_primary_metric => $detail_row{primary_metric} // '', | |
| 723 | detail_traffic => $detail_row{traffic_seen} // 0, | |
| 724 | detail_conf_pct => $detail_row{conf_pct} // '0.0%', | |
| 725 | detail_lift_pct => $detail_row{lift_pct} // '+0.0%', | |
| 726 | detail_leader_label => $detail_row{leader_label} // 'A', | |
| 727 | detail_leader_rate => $detail_row{leader_rate} // '0.00%', | |
| 728 | detail_loser_rate => $detail_row{loser_rate} // '0.00%', | |
| 729 | detail_created => $detail_row{created_at} // '', | |
| 730 | detail_started => $detail_row{start_date} // '-', | |
| 731 | detail_is_running => $detail_row{is_running} // 0, | |
| 732 | detail_is_draft => $detail_row{is_draft} // 0, | |
| 733 | detail_is_paused => $detail_row{is_paused} // 0, | |
| 734 | detail_is_complete => $detail_row{is_complete} // 0, | |
| 735 | detail_has_stats => $detail_row{has_stats} // 0, | |
| 736 | detail_winner_called => $detail_row{winner_called} // 0, | |
| 737 | detail_too_early => $detail_row{too_early} // 0, | |
| 738 | detail_below_min => $detail_row{below_min_sample}// 0, | |
| 739 | detail_has_any_data => $detail_row{has_any_data} // 0, | |
| 740 | detail_has_locked => $detail_row{has_locked_winner}// 0, | |
| 741 | detail_locked_winner => $detail_row{locked_winner_id} // '', | |
| 742 | detail_complete_confirm => $detail_row{complete_confirm}// '', | |
| 743 | detail_variants => \@detail_variants, | |
| 744 | ||
| 745 | # Tutorial flag drives the sample-data walkthrough. | |
| 746 | tutorial_mode => $tutorial_mode, | |
| 747 | not_tutorial_mode => $tutorial_mode ? 0 : 1, | |
| 748 | ||
| 749 | # Price tests + Van Westendorp surveys (previously "Coming soon") | |
| 750 | px_ready => $px_ready ? 1 : 0, | |
| 751 | px_not_ready => $px_ready ? 0 : 1, | |
| 752 | price_tests => \@test_rows, | |
| 753 | has_price_tests => scalar(@test_rows) ? 1 : 0, | |
| 754 | surveys => \@survey_rows, | |
| 755 | has_surveys => scalar(@survey_rows) ? 1 : 0, | |
| 756 | show_vw_results => (%vw_display && $vw_display{vw_n}) ? 1 : 0, | |
| 757 | vw_n => $vw_display{vw_n} // 0, | |
| 758 | vw_pmc => $vw_display{vw_pmc} // '-', | |
| 759 | vw_pme => $vw_display{vw_pme} // '-', | |
| 760 | vw_opp => $vw_display{vw_opp} // '-', | |
| 761 | vw_ipp => $vw_display{vw_ipp} // '-', | |
| 762 | ||
| 763 | opt_flash_msg => $opt_flash_msg, | |
| 764 | has_opt_flash => length $opt_flash_msg ? 1 : 0, | |
| 765 | opt_flash_kind => $opt_flash_kind, | |
| 766 | }; | |
| 767 | ||
| 768 | # Tutorial-mode overlay -- sample experiments, price tests, and ideas. | |
| 769 | # Painted only when ?tutorial=1; nothing here touches the DB. | |
| 770 | if ($tutorial_mode) { | |
| 771 | # Drive the same "has experiments" / list branches as the real path | |
| 772 | # by feeding the template a synthetic active+completed list. | |
| 773 | my @sample_active = ( | |
| 774 | { id=>'demo-1', name=>'Hero variant', test_type=>'AB', surface=>'hero_title', | |
| 775 | status=>'running', status_label=>'Running', | |
| 776 | is_draft=>0, is_running=>1, is_paused=>0, is_complete=>0, is_aborted=>0, | |
| 777 | confidence=>'96.4%', lift=>'+51.5%', traffic_seen=>2841, | |
| 778 | storefront=>'demo-studio.example', created_at=>'2026-05-05', | |
| 779 | leader_label=>'B', leader_rate=>'5.18%', has_any_data=>1, | |
| 780 | complete_confirm=>'Mark complete?' }, | |
| 781 | { id=>'demo-2', name=>'Bundle CTA copy', test_type=>'AB', surface=>'cta_label', | |
| 782 | status=>'running', status_label=>'Running', | |
| 783 | is_draft=>0, is_running=>1, is_paused=>0, is_complete=>0, is_aborted=>0, | |
| 784 | confidence=>'71.0%', lift=>'+8.4%', traffic_seen=>620, | |
| 785 | storefront=>'demo-studio.example', created_at=>'2026-05-08', | |
| 786 | leader_label=>'B', leader_rate=>'3.10%', has_any_data=>1, | |
| 787 | complete_confirm=>'Mark complete?' }, | |
| 788 | ); | |
| 789 | my @sample_completed = ( | |
| 790 | { id=>'demo-3', name=>'Catalog grid layout', test_type=>'MVT', surface=>'product_tile', | |
| 791 | status=>'complete', status_label=>'Complete', | |
| 792 | is_draft=>0, is_running=>0, is_paused=>0, is_complete=>1, is_aborted=>0, | |
| 793 | confidence=>'98.1%', lift=>'+12.0%', traffic_seen=>4120, | |
| 794 | storefront=>'demo-studio.example', created_at=>'2026-04-21', | |
| 795 | leader_label=>'B', leader_rate=>'4.40%', has_any_data=>1, | |
| 796 | complete_confirm=>'' }, | |
| 797 | { id=>'demo-4', name=>'Free shipping banner', test_type=>'AB', surface=>'hero_subtitle', | |
| 798 | status=>'complete', status_label=>'Complete', | |
| 799 | is_draft=>0, is_running=>0, is_paused=>0, is_complete=>1, is_aborted=>0, | |
| 800 | confidence=>'92.0%', lift=>'-4.2%', traffic_seen=>1820, | |
| 801 | storefront=>'demo-studio.example', created_at=>'2026-04-12', | |
| 802 | leader_label=>'A', leader_rate=>'2.80%', has_any_data=>1, | |
| 803 | complete_confirm=>'' }, | |
| 804 | ); | |
| 805 | my @sample_archived = ( | |
| 806 | { id=>'demo-5', name=>'Pricing card design', test_type=>'AB', surface=>'product_tile', | |
| 807 | status=>'aborted', status_label=>'Aborted', | |
| 808 | is_draft=>0, is_running=>0, is_paused=>0, is_complete=>0, is_aborted=>1, | |
| 809 | confidence=>'-', lift=>'-', traffic_seen=>0, | |
| 810 | storefront=>'demo-studio.example', created_at=>'2026-04-01', | |
| 811 | leader_label=>'A', leader_rate=>'0.00%', has_any_data=>0, | |
| 812 | complete_confirm=>'' }, | |
| 813 | ); | |
| 814 | my @sample_all = (@sample_active, @sample_completed, @sample_archived); | |
| 815 | ||
| 816 | $tvars->{experiments} = \@sample_all; | |
| 817 | $tvars->{has_experiments} = 1; | |
| 818 | $tvars->{experiment_count} = scalar @sample_all; | |
| 819 | $tvars->{experiments_active} = \@sample_active; | |
| 820 | $tvars->{experiments_completed} = \@sample_completed; | |
| 821 | $tvars->{experiments_archived} = \@sample_archived; | |
| 822 | $tvars->{has_active_experiments} = 1; | |
| 823 | $tvars->{has_completed_experiments} = 1; | |
| 824 | $tvars->{has_archived_experiments} = 1; | |
| 825 | $tvars->{active_count} = scalar @sample_active; | |
| 826 | $tvars->{completed_count} = scalar @sample_completed; | |
| 827 | $tvars->{archived_count} = scalar @sample_archived; | |
| 828 | $tvars->{has_storefront} = 1; | |
| 829 | } | |
| 830 | ||
| 831 | 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"; | |
| 832 | ||
| 833 | my $body = join('', $tfile->template('webstls_optimization.html', $tvars, $userinfo)); | |
| 834 | ||
| 835 | $wrap->render({ | |
| 836 | userinfo => $userinfo, | |
| 837 | page_key => 'optimize', | |
| 838 | title => 'Optimization', | |
| 839 | body => $body, | |
| 840 | extra_js => ['/assets/javascript/graphs.js'], | |
| 841 | }); | |
| 842 | ||
| 843 | sub _h { | |
| 844 | my ($s) = @_; | |
| 845 | $s //= ''; | |
| 846 | $s =~ s/&/&/g; | |
| 847 | $s =~ s/</</g; | |
| 848 | $s =~ s/>/>/g; | |
| 849 | $s =~ s/"/"/g; | |
| 850 | return $s; | |
| 851 | } | |
| 852 | ||
| 853 | # Parse the variants JSON into a list of hashes -- used to pre-populate | |
| 854 | # the edit form and to break out per-variant content on the detail | |
| 855 | # page. Mirrors the parser in MODS::WebSTLs::Experiments::_parse_variants | |
| 856 | # but lives here too so this CGI is self-contained for the rendering | |
| 857 | # path (the helper module is only loaded on the storefront side). | |
| 858 | sub _parse_variants_for_edit { | |
| 859 | my ($json) = @_; | |
| 860 | return () unless defined $json && length $json; | |
| 861 | my @out; | |
| 862 | while ($json =~ /\{"id":"([^"]+)","name":"((?:[^"\\]|\\.)*)","traffic_pct":(\d+)(?:,"target_model_id":(\d+))?,"changes":\{"text":"((?:[^"\\]|\\.)*)","image_url":"((?:[^"\\]|\\.)*)"(?:,"layout_id":(\d+))?(?:,"theme_id":(\d+))?(?:,"custom_theme_id":(\d+))?\}\}/g) { | |
| 863 | my ($id, $name, $pct, $target, $text, $img, $lid, $tid, $ctid) | |
| 864 | = ($1, $2, $3, $4, $5, $6, $7, $8, $9); | |
| 865 | for ($name, $text, $img) { | |
| 866 | s/\\"/"/g; | |
| 867 | s/\\\\/\\/g; | |
| 868 | s/\\n/\n/g; | |
| 869 | s/\\r/\r/g; | |
| 870 | s/\\t/\t/g; | |
| 871 | } | |
| 872 | push @out, { | |
| 873 | id => $id, | |
| 874 | name => $name, | |
| 875 | traffic_pct => $pct + 0, | |
| 876 | target_model_id => ($target // 0) + 0, | |
| 877 | text => $text, | |
| 878 | image_url => $img, | |
| 879 | layout_id => ($lid // 0) + 0, | |
| 880 | theme_id => ($tid // 0) + 0, | |
| 881 | custom_theme_id => ($ctid // 0) + 0, | |
| 882 | }; | |
| 883 | } | |
| 884 | return @out; | |
| 885 | } | |
| 886 | ||
| 887 | #====================================================================== | |
| 888 | # optimization_action entry: POST-only handlers for the ab_tests | |
| 889 | # mutations and Price test / Van Westendorp survey delegation. | |
| 890 | # require_feature('view_reports') applied above. | |
| 891 | #====================================================================== | |
| 892 | sub _handle_action { | |
| 893 | my ($q, $form, $userinfo) = @_; | |
| 894 | ||
| 895 | # POST-only. | |
| 896 | if (($ENV{REQUEST_METHOD} || '') ne 'POST') { | |
| 897 | print "Status: 405 Method Not Allowed\nContent-Type: text/plain\n\nPOST required\n"; | |
| 898 | return; | |
| 899 | } | |
| 900 | ||
| 901 | my $uid = $userinfo->{user_id}; | |
| 902 | $uid =~ s/[^0-9]//g; | |
| 903 | ||
| 904 | my $act = lc($form->{act} || ''); | |
| 905 | $act =~ s/[^a-z_]//g; | |
| 906 | ||
| 907 | my $dbh = $db->db_connect(); | |
| 908 | ||
| 909 | # Make sure ab_tests exists before doing anything. | |
| 910 | my $have_tbl = $db->db_readwrite($dbh, qq~ | |
| 911 | SELECT COUNT(*) AS n FROM information_schema.tables | |
| 912 | WHERE table_schema='$DB' AND table_name='ab_tests' | |
| 913 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 914 | unless ($have_tbl && $have_tbl->{n}) { | |
| 915 | $db->db_disconnect($dbh); | |
| 916 | print "Status: 302 Found\nLocation: /optimization.cgi\n\n"; | |
| 917 | return; | |
| 918 | } | |
| 919 | ||
| 920 | # Surface column may or may not have been added yet. Skip writing it | |
| 921 | # when absent so a fresh DB does not 500. | |
| 922 | my $col = $db->db_readwrite($dbh, qq~ | |
| 923 | SELECT COUNT(*) AS n FROM information_schema.columns | |
| 924 | WHERE table_schema='$DB' AND table_name='ab_tests' AND column_name='surface' | |
| 925 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 926 | my $has_surface = ($col && $col->{n}) ? 1 : 0; | |
| 927 | ||
| 928 | # ---- SAVE: create-or-update from the builder form -------------------- | |
| 929 | # Same form posts to act=save with an optional `id` hidden field. When | |
| 930 | # id is missing we INSERT a new draft; when present we UPDATE the row | |
| 931 | # AND wipe any existing ab_test_events for it (editing the variants | |
| 932 | # invalidates collected data so we restart cleanly). | |
| 933 | if ($act eq 'save' || $act eq 'create') { | |
| 934 | my $name = substr($form->{name} || '', 0, 160); | |
| 935 | my $storefront_id = $form->{storefront_id} || 0; | |
| 936 | $storefront_id =~ s/[^0-9]//g; | |
| 937 | ||
| 938 | # Verify ownership of the storefront. | |
| 939 | my $sf = $db->db_readwrite($dbh, qq~ | |
| 940 | SELECT id FROM `${DB}`.storefronts | |
| 941 | WHERE id='$storefront_id' AND user_id='$uid' LIMIT 1 | |
| 942 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 943 | unless ($sf && $sf->{id}) { | |
| 944 | $db->db_disconnect($dbh); | |
| 945 | print "Status: 302 Found\nLocation: /optimization.cgi\n\n"; | |
| 946 | return; | |
| 947 | } | |
| 948 | ||
| 949 | my $test_type = lc($form->{test_type} || 'ab'); | |
| 950 | $test_type = 'ab' unless $test_type =~ /^(ab|mvt|split_url|redirect)$/; | |
| 951 | ||
| 952 | my $surface = $form->{surface} || ''; | |
| 953 | $surface =~ s/[^a-z0-9_]//g; | |
| 954 | $surface = substr($surface, 0, 64); | |
| 955 | # Whitelist the surfaces we understand. Falls back to hero_title | |
| 956 | # rather than '' so the experiment renders something predictable. | |
| 957 | my %ALLOWED_SURFACE = map { $_ => 1 } qw( | |
| 958 | hero_title hero_subtitle hero_image hero_video | |
| 959 | cta_label product_tile section_heading custom | |
| 960 | layout theme layout_and_theme | |
| 961 | storefront_page page_blocks | |
| 962 | ); | |
| 963 | $surface = 'hero_title' unless $ALLOWED_SURFACE{$surface}; | |
| 964 | ||
| 965 | my $primary_metric = $form->{primary_metric} || 'conversion_rate'; | |
| 966 | $primary_metric =~ s/[^a-z0-9_]//g; | |
| 967 | $primary_metric = substr($primary_metric, 0, 80); | |
| 968 | ||
| 969 | my $confidence = $form->{confidence_threshold} || '0.95'; | |
| 970 | $confidence =~ s/[^0-9.]//g; | |
| 971 | $confidence = '0.95' unless $confidence; | |
| 972 | ||
| 973 | # When surface=product_tile, the variants test a specific model's | |
| 974 | # tile content (title + image). Validate the model belongs to the | |
| 975 | # logged-in user; if it doesn't, zero out target_model_id so the | |
| 976 | # experiment falls back to a no-op on the storefront render path. | |
| 977 | my $target_id = 0; | |
| 978 | if ($surface eq 'product_tile') { | |
| 979 | my $raw = $form->{target_model_id} || 0; | |
| 980 | $raw =~ s/[^0-9]//g; | |
| 981 | if ($raw) { | |
| 982 | my $owns = $db->db_readwrite($dbh, qq~ | |
| 983 | SELECT id FROM `${DB}`.models | |
| 984 | WHERE id='$raw' AND user_id='$uid' AND purged_at IS NULL | |
| 985 | LIMIT 1 | |
| 986 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 987 | $target_id = ($owns && $owns->{id}) ? $raw : 0; | |
| 988 | } | |
| 989 | } | |
| 990 | ||
| 991 | # Read the per-variant rows from the form. The builder uses single | |
| 992 | # uppercase letter ids (A..F). For backward compatibility we also | |
| 993 | # honour variant_a_* / variant_b_* (old form names) when the | |
| 994 | # numbered fields are absent. | |
| 995 | my @LETTERS = ('A', 'B', 'C', 'D', 'E', 'F'); | |
| 996 | my @variant_specs; | |
| 997 | foreach my $vid (@LETTERS) { | |
| 998 | my $lc = lc $vid; # 'a', 'b', ... | |
| 999 | my $text = defined $form->{"variant_${vid}_text"} | |
| 1000 | ? $form->{"variant_${vid}_text"} | |
| 1001 | : $form->{"variant_${lc}_text"}; | |
| 1002 | my $img_field = "variant_${vid}_image"; | |
| 1003 | my $img_url = _act_upload_image_if_present($q, $img_field); | |
| 1004 | unless (length $img_url) { | |
| 1005 | # Fall back to lowercase legacy field name. | |
| 1006 | $img_url = _act_upload_image_if_present($q, "variant_${lc}_image"); | |
| 1007 | } | |
| 1008 | # Allow caller to pass an explicit image URL for an existing | |
| 1009 | # variant when no new file was uploaded (edit mode preserves | |
| 1010 | # the previously uploaded image). | |
| 1011 | unless (length $img_url) { | |
| 1012 | my $existing = $form->{"variant_${vid}_image_existing"} | |
| 1013 | // $form->{"variant_${lc}_image_existing"} | |
| 1014 | // ''; | |
| 1015 | if ($existing =~ m{^/uploads/[A-Za-z0-9_./-]+$}) { | |
| 1016 | $img_url = $existing; | |
| 1017 | } | |
| 1018 | } | |
| 1019 | my $lid = $form->{"variant_${vid}_layout_id"}; | |
| 1020 | my $tid = $form->{"variant_${vid}_theme_id"}; | |
| 1021 | my $ctid = $form->{"variant_${vid}_custom_theme_id"}; | |
| 1022 | my $vpid = $form->{"variant_${vid}_page_id"}; | |
| 1023 | for ($lid, $tid, $ctid, $vpid) { | |
| 1024 | $_ = '' unless defined $_; | |
| 1025 | s/[^0-9]//g; | |
| 1026 | $_ = $_ ? ($_ + 0) : 0; | |
| 1027 | } | |
| 1028 | # Per-block MVT override map. Passed in as a JSON-shaped string | |
| 1029 | # the storefront-editor JS built. We don't parse it here -- the | |
| 1030 | # storefront page renderer will. We just need to round-trip it | |
| 1031 | # safely into the variants column. | |
| 1032 | my $block_overrides_json = $form->{"variant_${vid}_block_overrides"}; | |
| 1033 | $block_overrides_json = '' unless defined $block_overrides_json; | |
| 1034 | my $name = $form->{"variant_${vid}_name"}; | |
| 1035 | $name = '' unless defined $name; | |
| 1036 | $name = substr($name, 0, 120); | |
| 1037 | ||
| 1038 | # Decide whether this variant row was filled in by the user. | |
| 1039 | # Non-design surfaces care about text + image; design surfaces | |
| 1040 | # care about layout_id / theme_id / custom_theme_id. Page tests | |
| 1041 | # care about variant_page_id / block_overrides. The first two | |
| 1042 | # rows (A control, B challenger) are always emitted even if | |
| 1043 | # empty so an A/B test has a baseline shape. | |
| 1044 | my $filled = ( | |
| 1045 | (defined $text && length $text) | |
| 1046 | || length $img_url | |
| 1047 | || $lid > 0 | |
| 1048 | || $tid > 0 | |
| 1049 | || $ctid > 0 | |
| 1050 | || $vpid > 0 | |
| 1051 | || length $block_overrides_json | |
| 1052 | || length $name | |
| 1053 | ) ? 1 : 0; | |
| 1054 | my $is_required = ($vid eq 'A' || $vid eq 'B') ? 1 : 0; | |
| 1055 | next unless $filled || $is_required; | |
| 1056 | ||
| 1057 | # Default label when seller didn't type one. | |
| 1058 | unless (length $name) { | |
| 1059 | $name = ($vid eq 'A') ? 'Control' | |
| 1060 | : ($vid eq 'B') ? 'Challenger' | |
| 1061 | : 'Variant ' . $vid; | |
| 1062 | } | |
| 1063 | ||
| 1064 | push @variant_specs, { | |
| 1065 | id => $vid, | |
| 1066 | name => $name, | |
| 1067 | text => (defined $text ? $text : ''), | |
| 1068 | image_url => $img_url, | |
| 1069 | target_model_id => $target_id, | |
| 1070 | layout_id => $lid, | |
| 1071 | theme_id => $tid, | |
| 1072 | custom_theme_id => $ctid, | |
| 1073 | variant_page_id => $vpid, | |
| 1074 | block_overrides_json => $block_overrides_json, | |
| 1075 | }; | |
| 1076 | } | |
| 1077 | # Always at least 2 (A + B). | |
| 1078 | while (scalar(@variant_specs) < 2) { | |
| 1079 | my $vid = $LETTERS[scalar(@variant_specs)]; | |
| 1080 | push @variant_specs, { | |
| 1081 | id => $vid, | |
| 1082 | name => ($vid eq 'A' ? 'Control' : 'Challenger'), | |
| 1083 | text => '', | |
| 1084 | image_url => '', | |
| 1085 | target_model_id => $target_id, | |
| 1086 | layout_id => 0, | |
| 1087 | theme_id => 0, | |
| 1088 | custom_theme_id => 0, | |
| 1089 | variant_page_id => 0, | |
| 1090 | block_overrides_json => '', | |
| 1091 | }; | |
| 1092 | } | |
| 1093 | ||
| 1094 | # Even traffic split across the variants we wound up with. Integer | |
| 1095 | # percentages so the row totals to <=100 (rounding leftover lands | |
| 1096 | # on the control). 2 variants = 50/50, 3 = 33/33/34, etc. | |
| 1097 | my $n = scalar @variant_specs; | |
| 1098 | my $pct = int(100 / $n); | |
| 1099 | my $rem = 100 - ($pct * $n); | |
| 1100 | for (my $i = 0; $i < $n; $i++) { | |
| 1101 | $variant_specs[$i]->{traffic_pct} = $pct + ($i == 0 ? $rem : 0); | |
| 1102 | } | |
| 1103 | ||
| 1104 | my $variants_json = _act_variants_json(@variant_specs); | |
| 1105 | ||
| 1106 | # SQL-escape strings. | |
| 1107 | for ($name, $surface, $primary_metric, $variants_json) { | |
| 1108 | s/\\/\\\\/g; | |
| 1109 | s/'/\\'/g; | |
| 1110 | } | |
| 1111 | ||
| 1112 | my $surface_sql = $has_surface ? "surface='$surface'," : ''; | |
| 1113 | ||
| 1114 | # Edit vs. create: if `id` is present (and the row belongs to us), | |
| 1115 | # UPDATE in place and wipe events; otherwise INSERT a new draft. | |
| 1116 | my $edit_id = $form->{id} || 0; | |
| 1117 | $edit_id =~ s/[^0-9]//g; | |
| 1118 | ||
| 1119 | if ($edit_id) { | |
| 1120 | my $own = $db->db_readwrite($dbh, qq~ | |
| 1121 | SELECT ab.id | |
| 1122 | FROM `${DB}`.ab_tests ab | |
| 1123 | JOIN `${DB}`.storefronts s ON s.id = ab.storefront_id | |
| 1124 | WHERE ab.id='$edit_id' AND s.user_id='$uid' | |
| 1125 | LIMIT 1 | |
| 1126 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1127 | unless ($own && $own->{id}) { | |
| 1128 | $db->db_disconnect($dbh); | |
| 1129 | print "Status: 302 Found\nLocation: /optimization.cgi\n\n"; | |
| 1130 | return; | |
| 1131 | } | |
| 1132 | ||
| 1133 | $db->db_readwrite($dbh, qq~ | |
| 1134 | UPDATE `${DB}`.ab_tests | |
| 1135 | SET name='$name', | |
| 1136 | test_type='$test_type', | |
| 1137 | $surface_sql | |
| 1138 | variants='$variants_json', | |
| 1139 | primary_metric='$primary_metric', | |
| 1140 | status='draft', | |
| 1141 | start_date=NULL, | |
| 1142 | end_date=NULL, | |
| 1143 | winner_variant_id=NULL, | |
| 1144 | confidence_score=NULL, | |
| 1145 | traffic_seen=0 | |
| 1146 | WHERE id='$edit_id' | |
| 1147 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1148 | ||
| 1149 | # Editing variants invalidates the existing stats. Clear events | |
| 1150 | # so the new run starts from zero -- the previous mix of A/B | |
| 1151 | # exposures cannot fairly be compared to the edited variants. | |
| 1152 | $db->db_readwrite($dbh, qq~ | |
| 1153 | DELETE FROM `${DB}`.ab_test_events WHERE ab_test_id='$edit_id' | |
| 1154 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1155 | ||
| 1156 | $db->db_disconnect($dbh); | |
| 1157 | print "Status: 302 Found\nLocation: /optimization.cgi?saved=1\n\n"; | |
| 1158 | return; | |
| 1159 | } | |
| 1160 | ||
| 1161 | $db->db_readwrite($dbh, qq~ | |
| 1162 | INSERT INTO `${DB}`.ab_tests | |
| 1163 | SET storefront_id='$storefront_id', | |
| 1164 | name='$name', | |
| 1165 | test_type='$test_type', | |
| 1166 | $surface_sql | |
| 1167 | variants='$variants_json', | |
| 1168 | primary_metric='$primary_metric', | |
| 1169 | status='draft', | |
| 1170 | created_at=NOW() | |
| 1171 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1172 | ||
| 1173 | $db->db_disconnect($dbh); | |
| 1174 | print "Status: 302 Found\nLocation: /optimization.cgi?saved=1\n\n"; | |
| 1175 | return; | |
| 1176 | } | |
| 1177 | ||
| 1178 | # All other actions need an experiment id + ownership check. | |
| 1179 | my $exp_id = $form->{id} || 0; | |
| 1180 | $exp_id =~ s/[^0-9]//g; | |
| 1181 | if (!$exp_id) { | |
| 1182 | $db->db_disconnect($dbh); | |
| 1183 | print "Status: 302 Found\nLocation: /optimization.cgi\n\n"; | |
| 1184 | return; | |
| 1185 | } | |
| 1186 | ||
| 1187 | # Verify the experiment belongs to the logged-in user. | |
| 1188 | my $own = $db->db_readwrite($dbh, qq~ | |
| 1189 | SELECT ab.id, ab.status | |
| 1190 | FROM `${DB}`.ab_tests ab | |
| 1191 | JOIN `${DB}`.storefronts s ON s.id = ab.storefront_id | |
| 1192 | WHERE ab.id='$exp_id' AND s.user_id='$uid' | |
| 1193 | LIMIT 1 | |
| 1194 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1195 | unless ($own && $own->{id}) { | |
| 1196 | $db->db_disconnect($dbh); | |
| 1197 | print "Status: 302 Found\nLocation: /optimization.cgi\n\n"; | |
| 1198 | return; | |
| 1199 | } | |
| 1200 | ||
| 1201 | if ($act eq 'start') { | |
| 1202 | # draft|paused -> running. Set start_date if not already set. | |
| 1203 | $db->db_readwrite($dbh, qq~ | |
| 1204 | UPDATE `${DB}`.ab_tests | |
| 1205 | SET status='running', | |
| 1206 | start_date=COALESCE(start_date, NOW()) | |
| 1207 | WHERE id='$exp_id' | |
| 1208 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1209 | } | |
| 1210 | elsif ($act eq 'pause') { | |
| 1211 | $db->db_readwrite($dbh, qq~ | |
| 1212 | UPDATE `${DB}`.ab_tests | |
| 1213 | SET status='paused' | |
| 1214 | WHERE id='$exp_id' | |
| 1215 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1216 | } | |
| 1217 | elsif ($act eq 'complete') { | |
| 1218 | # Mark the test complete AND lock in the winning variant based on | |
| 1219 | # the conversion data collected so far. The winner is whichever | |
| 1220 | # variant has the higher conversion rate; ties go to the control | |
| 1221 | # (variant A). If no data has been collected at all, the control | |
| 1222 | # wins by default and the confidence stays NULL. | |
| 1223 | require MODS::WebSTLs::Experiments; | |
| 1224 | my $exh = MODS::WebSTLs::Experiments->new; | |
| 1225 | my $stats = $exh->compute_stats($db, $dbh, $DB, $exp_id) || {}; | |
| 1226 | ||
| 1227 | # Pull the first variant id from the JSON so we have a default | |
| 1228 | # "control" id even when compute_stats returns nothing (no data). | |
| 1229 | my $first_id = ''; | |
| 1230 | my $row = $db->db_readwrite($dbh, qq~ | |
| 1231 | SELECT variants FROM `${DB}`.ab_tests WHERE id='$exp_id' LIMIT 1 | |
| 1232 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1233 | if ($row && $row->{variants} && $row->{variants} =~ /\{"id":"([^"]+)"/) { | |
| 1234 | $first_id = $1; | |
| 1235 | } | |
| 1236 | ||
| 1237 | my $winner_id; | |
| 1238 | if ($stats && exists $stats->{rate_a}) { | |
| 1239 | # Pick the variant with the higher rate. Ties (incl. both 0) | |
| 1240 | # go to the control so we never accidentally promote an | |
| 1241 | # untested challenger. | |
| 1242 | if (($stats->{rate_b} || 0) > ($stats->{rate_a} || 0)) { | |
| 1243 | $winner_id = $stats->{winner_id}; | |
| 1244 | } else { | |
| 1245 | $winner_id = $stats->{control_id}; | |
| 1246 | } | |
| 1247 | } | |
| 1248 | $winner_id = $first_id unless $winner_id; | |
| 1249 | $winner_id =~ s/[^A-Za-z0-9_\-]//g; | |
| 1250 | ||
| 1251 | my $conf_sql = (defined $stats->{confidence}) | |
| 1252 | ? sprintf('%.4f', $stats->{confidence}) | |
| 1253 | : 'NULL'; | |
| 1254 | ||
| 1255 | $db->db_readwrite($dbh, qq~ | |
| 1256 | UPDATE `${DB}`.ab_tests | |
| 1257 | SET status='complete', | |
| 1258 | end_date=COALESCE(end_date, NOW()), | |
| 1259 | winner_variant_id='$winner_id', | |
| 1260 | confidence_score=$conf_sql | |
| 1261 | WHERE id='$exp_id' | |
| 1262 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1263 | } | |
| 1264 | elsif ($act eq 'archive') { | |
| 1265 | # Archive: hide from the main view but keep history. Distinct from | |
| 1266 | # delete (which removes the row entirely). Reachable via the | |
| 1267 | # Archived section. | |
| 1268 | $db->db_readwrite($dbh, qq~ | |
| 1269 | UPDATE `${DB}`.ab_tests | |
| 1270 | SET status='aborted', | |
| 1271 | end_date=COALESCE(end_date, NOW()) | |
| 1272 | WHERE id='$exp_id' | |
| 1273 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1274 | } | |
| 1275 | elsif ($act eq 'unarchive') { | |
| 1276 | # Bring a previously-archived row back to Paused so the user can | |
| 1277 | # decide whether to resume, edit, or re-complete it. | |
| 1278 | $db->db_readwrite($dbh, qq~ | |
| 1279 | UPDATE `${DB}`.ab_tests | |
| 1280 | SET status='paused', | |
| 1281 | end_date=NULL | |
| 1282 | WHERE id='$exp_id' | |
| 1283 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1284 | } | |
| 1285 | elsif ($act eq 'reset_stats') { | |
| 1286 | # Wipe the events for this experiment and zero out the cached | |
| 1287 | # confidence + traffic counters. The variants and config stay | |
| 1288 | # intact -- only the collected data resets. Status flips back to | |
| 1289 | # draft so the user can deliberately re-Start when ready. | |
| 1290 | $db->db_readwrite($dbh, qq~ | |
| 1291 | DELETE FROM `${DB}`.ab_test_events WHERE ab_test_id='$exp_id' | |
| 1292 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1293 | $db->db_readwrite($dbh, qq~ | |
| 1294 | UPDATE `${DB}`.ab_tests | |
| 1295 | SET status='draft', | |
| 1296 | start_date=NULL, | |
| 1297 | end_date=NULL, | |
| 1298 | winner_variant_id=NULL, | |
| 1299 | confidence_score=NULL, | |
| 1300 | traffic_seen=0 | |
| 1301 | WHERE id='$exp_id' | |
| 1302 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1303 | } | |
| 1304 | elsif ($act eq 'delete') { | |
| 1305 | # Hard delete. ab_test_events cascades via the foreign key. | |
| 1306 | $db->db_readwrite($dbh, qq~ | |
| 1307 | DELETE FROM `${DB}`.ab_tests WHERE id='$exp_id' | |
| 1308 | ~, $ENV{SCRIPT_NAME}, __LINE__); | |
| 1309 | } | |
| 1310 | ||
| 1311 | # ---- Price tests + Van Westendorp surveys --------------------------- | |
| 1312 | # Separate group of actions delegated to MODS::WebSTLs::PricingExperiments. | |
| 1313 | # These don't touch the ab_tests table; ownership / schema-readiness | |
| 1314 | # checks live in the helper. Each returns to /optimization.cgi with a | |
| 1315 | # fragment (#price or #survey) so the browser scrolls to the right tab. | |
| 1316 | elsif ($act eq 'create_price_test') { | |
| 1317 | require MODS::WebSTLs::PricingExperiments; | |
| 1318 | my $px = MODS::WebSTLs::PricingExperiments->new; | |
| 1319 | my $r = $px->create_price_test($db, $dbh, $DB, $userinfo->{user_id}, | |
| 1320 | model_id => $form->{model_id}, | |
| 1321 | min_price_cents => int(($form->{min_price_dollars} || 0) * 100), | |
| 1322 | max_price_cents => int(($form->{max_price_dollars} || 0) * 100), | |
| 1323 | step_cents => int(($form->{step_dollars} || 1) * 100), | |
| 1324 | trigger => $form->{trigger} || 'conversion', | |
| 1325 | cooldown_hours => $form->{cooldown_hours} || 24, | |
| 1326 | ); | |
| 1327 | $db->db_disconnect($dbh); | |
| 1328 | print "Status: 302 Found\nLocation: /optimization.cgi" | |
| 1329 | . ($r->{ok} ? '?ok=test_created#price' | |
| 1330 | : '?err=' . _act_u($r->{error} || 'failed') . '#price') | |
| 1331 | . "\n\n"; | |
| 1332 | return; | |
| 1333 | } | |
| 1334 | elsif ($act eq 'set_test_status') { | |
| 1335 | require MODS::WebSTLs::PricingExperiments; | |
| 1336 | my $px = MODS::WebSTLs::PricingExperiments->new; | |
| 1337 | my $r = $px->set_test_status($db, $dbh, $DB, $userinfo->{user_id}, | |
| 1338 | $form->{test_id}, $form->{status}); | |
| 1339 | $db->db_disconnect($dbh); | |
| 1340 | print "Status: 302 Found\nLocation: /optimization.cgi" | |
| 1341 | . ($r->{ok} ? '?ok=test_status#price' : '?err=denied#price') | |
| 1342 | . "\n\n"; | |
| 1343 | return; | |
| 1344 | } | |
| 1345 | elsif ($act eq 'delete_price_test') { | |
| 1346 | require MODS::WebSTLs::PricingExperiments; | |
| 1347 | my $px = MODS::WebSTLs::PricingExperiments->new; | |
| 1348 | my $r = $px->delete_price_test($db, $dbh, $DB, $userinfo->{user_id}, $form->{test_id}); | |
| 1349 | $db->db_disconnect($dbh); | |
| 1350 | print "Status: 302 Found\nLocation: /optimization.cgi" | |
| 1351 | . ($r->{ok} ? '?ok=test_deleted#price' : '?err=denied#price') | |
| 1352 | . "\n\n"; | |
| 1353 | return; | |
| 1354 | } | |
| 1355 | elsif ($act eq 'create_survey') { | |
| 1356 | require MODS::WebSTLs::PricingExperiments; | |
| 1357 | my $px = MODS::WebSTLs::PricingExperiments->new; | |
| 1358 | my $r = $px->create_survey($db, $dbh, $DB, $userinfo->{user_id}, | |
| 1359 | model_id => $form->{model_id}, | |
| 1360 | title => $form->{title}, | |
| 1361 | survey_type => $form->{survey_type} || 'van_westendorp', | |
| 1362 | ); | |
| 1363 | $db->db_disconnect($dbh); | |
| 1364 | print "Status: 302 Found\nLocation: /optimization.cgi" | |
| 1365 | . ($r->{ok} ? '?ok=survey_created#survey' | |
| 1366 | : '?err=' . _act_u($r->{error} || 'failed') . '#survey') | |
| 1367 | . "\n\n"; | |
| 1368 | return; | |
| 1369 | } | |
| 1370 | elsif ($act eq 'close_survey') { | |
| 1371 | require MODS::WebSTLs::PricingExperiments; | |
| 1372 | my $px = MODS::WebSTLs::PricingExperiments->new; | |
| 1373 | my $r = $px->close_survey($db, $dbh, $DB, $userinfo->{user_id}, $form->{survey_id}); | |
| 1374 | $db->db_disconnect($dbh); | |
| 1375 | print "Status: 302 Found\nLocation: /optimization.cgi" | |
| 1376 | . ($r->{ok} ? '?ok=survey_closed#survey' : '?err=denied#survey') | |
| 1377 | . "\n\n"; | |
| 1378 | return; | |
| 1379 | } | |
| 1380 | elsif ($act eq 'delete_survey') { | |
| 1381 | require MODS::WebSTLs::PricingExperiments; | |
| 1382 | my $px = MODS::WebSTLs::PricingExperiments->new; | |
| 1383 | my $r = $px->delete_survey($db, $dbh, $DB, $userinfo->{user_id}, $form->{survey_id}); | |
| 1384 | $db->db_disconnect($dbh); | |
| 1385 | print "Status: 302 Found\nLocation: /optimization.cgi" | |
| 1386 | . ($r->{ok} ? '?ok=survey_deleted#survey' : '?err=denied#survey') | |
| 1387 | . "\n\n"; | |
| 1388 | return; | |
| 1389 | } | |
| 1390 | ||
| 1391 | $db->db_disconnect($dbh); | |
| 1392 | print "Status: 302 Found\nLocation: /optimization.cgi\n\n"; | |
| 1393 | return; | |
| 1394 | } | |
| 1395 | ||
| 1396 | # URL encoder for redirect query strings. | |
| 1397 | sub _act_u { | |
| 1398 | my $s = shift; $s = '' unless defined $s; | |
| 1399 | $s =~ s/([^A-Za-z0-9\-_.~])/sprintf('%%%02X', ord($1))/eg; | |
| 1400 | return $s; | |
| 1401 | } | |
| 1402 | ||
| 1403 | #====================================================================== | |
| 1404 | # Helpers (action) | |
| 1405 | #====================================================================== | |
| 1406 | ||
| 1407 | # Read an uploaded file from the current CGI request, write it under | |
| 1408 | # /uploads/, return the URL. Returns '' if no upload was attached. | |
| 1409 | sub _act_upload_image_if_present { | |
| 1410 | my ($q, $field) = @_; | |
| 1411 | my $fh = $q->upload($field); | |
| 1412 | return '' unless $fh; | |
| 1413 | ||
| 1414 | # Read into memory. (Optimization images are typically small -- we | |
| 1415 | # cap reads at ~10MB to avoid runaway memory if a buyer uploads a | |
| 1416 | # huge file.) | |
| 1417 | my $bytes = ''; | |
| 1418 | my $cap = 10 * 1024 * 1024; | |
| 1419 | my $buf; | |
| 1420 | while (read($fh, $buf, 8192)) { | |
| 1421 | $bytes .= $buf; | |
| 1422 | last if length($bytes) > $cap; | |
| 1423 | } | |
| 1424 | return '' unless length($bytes); | |
| 1425 | ||
| 1426 | # Generate an opaque id + extension. Detect a few common types. | |
| 1427 | my @hex = ('0'..'9', 'a'..'f'); | |
| 1428 | my $id = ''; | |
| 1429 | $id .= $hex[int(rand(@hex))] for 1..24; | |
| 1430 | ||
| 1431 | my $ext = 'bin'; | |
| 1432 | if (substr($bytes, 0, 8) eq "\x89PNG\r\n\x1a\n") { $ext = 'png'; } | |
| 1433 | elsif (substr($bytes, 0, 3) eq "\xff\xd8\xff") { $ext = 'jpg'; } | |
| 1434 | elsif (substr($bytes, 0, 4) eq 'GIF8') { $ext = 'gif'; } | |
| 1435 | elsif (substr($bytes, 0, 4) eq 'RIFF' && | |
| 1436 | substr($bytes, 8, 4) eq 'WEBP') { $ext = 'webp'; } | |
| 1437 | ||
| 1438 | my $dir = '/var/www/vhosts/webstls.com/httpdocs/uploads'; | |
| 1439 | if (-d $dir) { | |
| 1440 | my $path = "$dir/exp_$id.$ext"; | |
| 1441 | if (open(my $w, '>', $path)) { | |
| 1442 | binmode $w; | |
| 1443 | print $w $bytes; | |
| 1444 | close $w; | |
| 1445 | return "/uploads/exp_$id.$ext"; | |
| 1446 | } | |
| 1447 | } | |
| 1448 | return ''; | |
| 1449 | } | |
| 1450 | ||
| 1451 | # Build the variants JSON we store in ab_tests.variants. Each variant | |
| 1452 | # has id, name, traffic_pct, changes:{text,image_url}. All string | |
| 1453 | # values get JSON-escaped. | |
| 1454 | sub _act_variants_json { | |
| 1455 | my @variants = @_; | |
| 1456 | my @parts; | |
| 1457 | foreach my $v (@variants) { | |
| 1458 | my $text = _act_json_str($v->{text} // ''); | |
| 1459 | my $img = _act_json_str($v->{image_url} // ''); | |
| 1460 | my $name = _act_json_str($v->{name} // ''); | |
| 1461 | my $id = _act_json_str($v->{id} // ''); | |
| 1462 | my $pct = ($v->{traffic_pct} || 0) + 0; | |
| 1463 | # target_model_id is 0 for non-product_tile experiments. Always | |
| 1464 | # written so the parser sees a consistent shape. | |
| 1465 | my $tid_model = ($v->{target_model_id} || 0) + 0; | |
| 1466 | # Design fields. Always written (as 0 when not set) so the | |
| 1467 | # parser in Experiments.pm and optimization.cgi sees a | |
| 1468 | # deterministic shape regardless of surface type. | |
| 1469 | my $lid = ($v->{layout_id} || 0) + 0; | |
| 1470 | my $tid_theme = ($v->{theme_id} || 0) + 0; | |
| 1471 | my $ctid = ($v->{custom_theme_id} || 0) + 0; | |
| 1472 | # storefront_page A/B test pointer. | |
| 1473 | my $vpid = ($v->{variant_page_id} || 0) + 0; | |
| 1474 | # Per-block MVT overrides. Stored as a JSON-escaped string so | |
| 1475 | # the outer parser only has to read it as a single field; the | |
| 1476 | # block content can contain commas, colons, and braces without | |
| 1477 | # breaking the variant boundary. | |
| 1478 | my $blocks_raw = $v->{block_overrides_json} // ''; | |
| 1479 | my $blocks = _act_json_str($blocks_raw); | |
| 1480 | push @parts, | |
| 1481 | qq~{"id":"$id","name":"$name","traffic_pct":$pct,~ . | |
| 1482 | qq~"target_model_id":$tid_model,~ . | |
| 1483 | qq~"changes":{"text":"$text","image_url":"$img",~ . | |
| 1484 | qq~"layout_id":$lid,"theme_id":$tid_theme,"custom_theme_id":$ctid,~ . | |
| 1485 | qq~"variant_page_id":$vpid,"block_overrides":"$blocks"}}~; | |
| 1486 | } | |
| 1487 | return '[' . join(',', @parts) . ']'; | |
| 1488 | } | |
| 1489 | ||
| 1490 | sub _act_json_str { | |
| 1491 | my $s = shift; | |
| 1492 | $s = '' unless defined $s; | |
| 1493 | $s =~ s/\\/\\\\/g; | |
| 1494 | $s =~ s/"/\\"/g; | |
| 1495 | $s =~ s/\r/\\r/g; | |
| 1496 | $s =~ s/\n/\\n/g; | |
| 1497 | $s =~ s/\t/\\t/g; | |
| 1498 | return $s; | |
| 1499 | } |