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

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

added on local at 2026-07-01 13:47:37

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