Diff -- /var/www/vhosts/3dshawn.com/shop.3dshawn.com/optimization.cgi
Diff

/var/www/vhosts/3dshawn.com/shop.3dshawn.com/optimization.cgi

added on local at 2026-07-01 22:09:42

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