Diff -- /var/www/vhosts/3dshawn.com/abforge.3dshawn.com/MODS/ABForge/Experiments.pm
Diff

/var/www/vhosts/3dshawn.com/abforge.3dshawn.com/MODS/ABForge/Experiments.pm

added on local at 2026-07-01 16:01:27

Added
+803
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to 31b451b081dd
Restore this content →
Unified diff
Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.
1package MODS::ABForge::Experiments;
2#======================================================================
3# ABForge -- A/B + MVT runtime.
4#
5# Three responsibilities:
6# 1. Pull running experiments for a storefront, parse their variants
7# JSON, and deterministically assign a visitor to one variant per
8# experiment based on a sticky cookie hash.
9# 2. Log events into ab_test_events as visitors flow through the
10# storefront (exposure on render, click via JS, add_to_cart from
11# cart_add.cgi, purchase from checkout.cgi).
12# 3. Compute Bayesian P(B beats A) on demand so the optimization
13# dashboard can show real confidence + traffic numbers.
14#
15# Tables used (already in db_schema.sql):
16# ab_tests - the experiments themselves (variants stored as JSON)
17# ab_test_events - one row per visitor event tied to a variant
18#
19# Visitor identity is a 32-char hex cookie (abforge_visitor) hashed with
20# SHA1 -> 40-char ab_test_events.visitor_hash. Same visitor always
21# resolves to the same variant for a given experiment (no flicker).
22#======================================================================
23use strict;
24use warnings;
25use Digest::SHA qw(sha1_hex);
26
27sub new {
28 my ($class) = @_;
29 return bless({}, $class);
30}
31
32#----------------------------------------------------------------------
33# Visitor cookie helpers
34#----------------------------------------------------------------------
35
36# Read the abforge_visitor cookie value from the request. Returns ''
37# when not yet set; the caller should mint a token + Set-Cookie header.
38sub read_visitor {
39 my ($self, $q) = @_;
40 my $tok = $q->cookie('abforge_visitor');
41 return '' unless defined $tok;
42 $tok =~ s/[^a-f0-9]//g;
43 return '' if length($tok) < 16 || length($tok) > 64;
44 return $tok;
45}
46
47# Mint a fresh visitor token + return (token, Set-Cookie line).
48# Caller emits the Set-Cookie header before any body output.
49sub mint_visitor {
50 my ($self) = @_;
51 my @hex = ('0'..'9', 'a'..'f');
52 my $tok = '';
53 $tok .= $hex[int(rand(@hex))] for 1..32;
54 my $cookie = qq~abforge_visitor=$tok; Max-Age=7776000; Path=/; SameSite=Lax; HttpOnly~;
55 return ($tok, $cookie);
56}
57
58# Hash a visitor token down to the 40-char id we store in
59# ab_test_events.visitor_hash. Stable across requests.
60sub visitor_hash {
61 my ($self, $token) = @_;
62 return '' unless $token;
63 return sha1_hex($token);
64}
65
66#----------------------------------------------------------------------
67# Experiment retrieval + variant assignment
68#----------------------------------------------------------------------
69
70# Has the ab_tests table been created on this server? Cached per
71# request -- avoids 500ing on a stale DB and avoids repeated checks.
72sub _has_tbl {
73 my ($self, $db, $dbh, $DB) = @_;
74 return $self->{_has_tbl} if exists $self->{_has_tbl};
75 my $r = $db->db_readwrite($dbh, qq~
76 SELECT COUNT(*) AS n FROM information_schema.tables
77 WHERE table_schema='$DB' AND table_name='ab_tests'
78 ~, $ENV{SCRIPT_NAME}, __LINE__);
79 $self->{_has_tbl} = ($r && $r->{n}) ? 1 : 0;
80 return $self->{_has_tbl};
81}
82
83# Does the surface column exist? (Added in a follow-up migration.)
84sub _has_surface {
85 my ($self, $db, $dbh, $DB) = @_;
86 return $self->{_has_surface} if exists $self->{_has_surface};
87 my $r = $db->db_readwrite($dbh, qq~
88 SELECT COUNT(*) AS n FROM information_schema.columns
89 WHERE table_schema='$DB' AND table_name='ab_tests'
90 AND column_name='surface'
91 ~, $ENV{SCRIPT_NAME}, __LINE__);
92 $self->{_has_surface} = ($r && $r->{n}) ? 1 : 0;
93 return $self->{_has_surface};
94}
95
96# Return all running experiments for a storefront. Each entry is a
97# hashref { id, surface, primary_metric, variants => [ {id,name,traffic_pct,text,image_url}, ... ] }.
98sub active_for_storefront {
99 my ($self, $db, $dbh, $DB, $storefront_id) = @_;
100 return () unless $storefront_id && $self->_has_tbl($db, $dbh, $DB);
101 $storefront_id =~ s/[^0-9]//g;
102 return () unless $storefront_id;
103
104 my $surface_sql = $self->_has_surface($db, $dbh, $DB) ? 'surface' : "'' AS surface";
105 my @rows = $db->db_readwrite_multiple($dbh, qq~
106 SELECT id, $surface_sql, primary_metric, page_id, variants
107 FROM `${DB}`.ab_tests
108 WHERE storefront_id='$storefront_id' AND status='running'
109 ~, $ENV{SCRIPT_NAME}, __LINE__);
110
111 my @out;
112 foreach my $r (@rows) {
113 my @vars = $self->_parse_variants($r->{variants} || '');
114 next unless @vars;
115 push @out, {
116 id => $r->{id},
117 surface => $r->{surface} || '',
118 primary_metric => $r->{primary_metric} || 'conversion_rate',
119 page_id => ($r->{page_id} || 0) + 0,
120 variants => \@vars,
121 };
122 }
123 return @out;
124}
125
126# Pick a variant for this visitor + experiment. Deterministic: same
127# visitor always lands on the same variant. Weighted by traffic_pct
128# (which defaults to 50/50 for A/B and even split for MVT).
129sub assign_variant {
130 my ($self, $visitor_hash, $experiment) = @_;
131 return undef unless $experiment && $experiment->{variants}
132 && @{ $experiment->{variants} };
133
134 # Pick a 0-99 bucket using SHA1(visitor + experiment_id). Mod by the
135 # total declared traffic_pct so unusual splits (e.g., 80/20) work.
136 my $key = ($visitor_hash || 'anon') . ':' . $experiment->{id};
137 my $bucket = hex(substr(sha1_hex($key), 0, 8));
138
139 my $total_pct = 0;
140 $total_pct += ($_->{traffic_pct} || 0) for @{ $experiment->{variants} };
141 $total_pct ||= scalar(@{ $experiment->{variants} });
142
143 my $pos = $bucket % $total_pct;
144 my $cum = 0;
145 foreach my $v (@{ $experiment->{variants} }) {
146 $cum += ($v->{traffic_pct} || 1);
147 return $v if $pos < $cum;
148 }
149 return $experiment->{variants}->[-1]; # fallback
150}
151
152#----------------------------------------------------------------------
153# Event logging
154#----------------------------------------------------------------------
155
156# Insert one row in ab_test_events. event_type must be one of the enum
157# values; anything else gets coerced to 'custom'. event_value is
158# optional and used for revenue events.
159sub log_event {
160 my ($self, $db, $dbh, $DB, $experiment_id, $variant_id, $visitor_hash, $event_type, $event_value) = @_;
161 return unless $experiment_id && $visitor_hash;
162 return unless $self->_has_tbl($db, $dbh, $DB);
163
164 $experiment_id =~ s/[^0-9]//g;
165 $variant_id = '' unless defined $variant_id;
166 $variant_id =~ s/[^A-Za-z0-9_\-]//g;
167 $visitor_hash =~ s/[^a-f0-9]//g;
168 $event_type = '' unless defined $event_type;
169 $event_type =~ s/[^a-z_]//g;
170 $event_type = 'custom' unless $event_type =~ /^(exposure|view|click|add_to_cart|purchase|custom)$/;
171
172 my $val_sql = 'NULL';
173 if (defined $event_value && $event_value =~ /^[\d]+(\.[\d]+)?$/) {
174 $val_sql = $event_value;
175 }
176
177 $db->db_readwrite($dbh, qq~
178 INSERT INTO `${DB}`.ab_test_events
179 SET ab_test_id='$experiment_id',
180 variant_id='$variant_id',
181 visitor_hash='$visitor_hash',
182 event_type='$event_type',
183 event_value=$val_sql,
184 occurred_at=NOW()
185 ~, $ENV{SCRIPT_NAME}, __LINE__);
186}
187
188# Convenience: log a conversion-type event (add_to_cart, purchase) for
189# every experiment this visitor is currently bucketed into. The caller
190# does not need to know the assignments -- we recompute them
191# deterministically from the visitor hash.
192sub log_event_for_visitor_experiments {
193 my ($self, $db, $dbh, $DB, $storefront_id, $visitor_hash, $event_type, $event_value) = @_;
194 return unless $visitor_hash && $storefront_id;
195
196 foreach my $exp ($self->active_for_storefront($db, $dbh, $DB, $storefront_id)) {
197 my $v = $self->assign_variant($visitor_hash, $exp);
198 next unless $v;
199 $self->log_event($db, $dbh, $DB, $exp->{id}, $v->{id}, $visitor_hash, $event_type, $event_value);
200 }
201}
202
203#----------------------------------------------------------------------
204# Stats: Bayesian P(B beats A)
205#----------------------------------------------------------------------
206
207# Returns a hashref with:
208# exposures_a, exposures_b, conversions_a, conversions_b,
209# rate_a, rate_b, lift_pct, confidence (0-1), traffic_seen
210# When there are more than 2 variants, "A" is the first variant and
211# "B" is the variant with the highest conversion rate.
212sub compute_stats {
213 my ($self, $db, $dbh, $DB, $experiment_id) = @_;
214 return {} unless $experiment_id && $self->_has_tbl($db, $dbh, $DB);
215 $experiment_id =~ s/[^0-9]//g;
216 return {} unless $experiment_id;
217
218 my $exp = $db->db_readwrite($dbh, qq~
219 SELECT primary_metric, variants
220 FROM `${DB}`.ab_tests
221 WHERE id='$experiment_id' LIMIT 1
222 ~, $ENV{SCRIPT_NAME}, __LINE__);
223 return {} unless $exp && $exp->{variants};
224
225 my $metric = $exp->{primary_metric} || 'conversion_rate';
226 my $conv_event =
227 $metric eq 'conversion_rate' ? 'purchase' :
228 $metric eq 'add_to_cart' ? 'add_to_cart' :
229 $metric eq 'click' ? 'click' :
230 $metric eq 'signup' ? 'custom' :
231 'purchase';
232
233 # Distinct-visitor counts per variant per event type.
234 my @ex = $db->db_readwrite_multiple($dbh, qq~
235 SELECT variant_id, COUNT(DISTINCT visitor_hash) AS n
236 FROM `${DB}`.ab_test_events
237 WHERE ab_test_id='$experiment_id' AND event_type='exposure'
238 GROUP BY variant_id
239 ~, $ENV{SCRIPT_NAME}, __LINE__);
240
241 my @cv = $db->db_readwrite_multiple($dbh, qq~
242 SELECT variant_id, COUNT(DISTINCT visitor_hash) AS n
243 FROM `${DB}`.ab_test_events
244 WHERE ab_test_id='$experiment_id' AND event_type='$conv_event'
245 GROUP BY variant_id
246 ~, $ENV{SCRIPT_NAME}, __LINE__);
247
248 my %expo = map { $_->{variant_id} => $_->{n} } @ex;
249 my %conv = map { $_->{variant_id} => $_->{n} } @cv;
250
251 my @variants = $self->_parse_variants($exp->{variants});
252 return {} unless @variants >= 2;
253
254 # Control = first variant. Challenger = best-rate non-control.
255 my $a = $variants[0];
256 my ($best_b, $best_rate) = (undef, -1);
257 for (my $i = 1; $i < @variants; $i++) {
258 my $vid = $variants[$i]->{id};
259 my $e = $expo{$vid} || 0;
260 my $c = $conv{$vid} || 0;
261 my $r = $e ? ($c / $e) : 0;
262 if ($r > $best_rate) { $best_rate = $r; $best_b = $variants[$i]; }
263 }
264 return {} unless $best_b;
265
266 my $exp_a = $expo{$a->{id}} || 0;
267 my $exp_b = $expo{$best_b->{id}} || 0;
268 my $conv_a = $conv{$a->{id}} || 0;
269 my $conv_b = $conv{$best_b->{id}} || 0;
270
271 my $rate_a = $exp_a ? $conv_a / $exp_a : 0;
272 my $rate_b = $exp_b ? $conv_b / $exp_b : 0;
273 my $lift = $rate_a ? (($rate_b - $rate_a) / $rate_a * 100) : 0;
274 my $conf = $self->_p_b_beats_a($conv_a, $exp_a, $conv_b, $exp_b);
275
276 return {
277 exposures_a => $exp_a,
278 exposures_b => $exp_b,
279 conversions_a => $conv_a,
280 conversions_b => $conv_b,
281 rate_a => $rate_a,
282 rate_b => $rate_b,
283 lift_pct => $lift,
284 confidence => $conf,
285 traffic_seen => $exp_a + $exp_b,
286 control_id => $a->{id},
287 winner_id => $best_b->{id},
288 };
289}
290
291# Bayesian-flavoured P(B beats A) using a normal approximation of the
292# Beta posterior. Returns a probability in [0, 1].
293sub _p_b_beats_a {
294 my ($self, $conv_a, $exp_a, $conv_b, $exp_b) = @_;
295 return 0.5 if ($exp_a + $exp_b) < 1;
296
297 # Beta(1,1) prior -> Beta(1+conv, 1+exp-conv) posterior.
298 my $p_a = ($conv_a + 1) / ($exp_a + 2);
299 my $p_b = ($conv_b + 1) / ($exp_b + 2);
300 my $v_a = ($p_a * (1 - $p_a)) / ($exp_a + 3);
301 my $v_b = ($p_b * (1 - $p_b)) / ($exp_b + 3);
302 my $sd = sqrt($v_a + $v_b);
303 return 0.5 if $sd == 0;
304 my $z = ($p_b - $p_a) / $sd;
305 return $self->_normal_cdf($z);
306}
307
308# Standard-normal CDF approximation (Abramowitz & Stegun 26.2.17,
309# good to ~7.5e-8). Pure Perl, no deps.
310sub _normal_cdf {
311 my ($self, $z) = @_;
312 my $sign = $z < 0 ? -1 : 1;
313 my $x = abs($z) / sqrt(2);
314 my $t = 1 / (1 + 0.3275911 * $x);
315 my $y = 1 - (((((1.061405429 * $t - 1.453152027) * $t) + 1.421413741) * $t - 0.284496736) * $t + 0.254829592) * $t * exp(-$x * $x);
316 return 0.5 * (1 + $sign * $y);
317}
318
319#----------------------------------------------------------------------
320# Applying a variant assignment to template tvars
321#----------------------------------------------------------------------
322
323# Given an array of { surface, variant } pairs (the visitor's
324# assignments) and the storefront tvars, patch the tvars in-place so
325# the variant's content is what gets rendered.
326sub apply_to_tvars {
327 my ($self, $assignments, $tvars) = @_;
328 foreach my $a (@$assignments) {
329 my $surface = $a->{surface} || '';
330 my $v = $a->{variant};
331 next unless $v;
332
333 my $text = $v->{text} // '';
334 my $img = $v->{image_url} // '';
335
336 if ($surface eq 'hero_title' && length $text) {
337 $tvars->{hero_title} = $text;
338 }
339 elsif ($surface eq 'hero_subtitle' && length $text) {
340 $tvars->{store_tagline} = $text;
341 }
342 elsif ($surface eq 'hero_image' && length $img) {
343 $tvars->{hero_image_1} = $img;
344 }
345 elsif ($surface eq 'hero_video' && length $img) {
346 # No dedicated hero_video tvar yet -- store it in hero_image_1
347 # for now; the layout renders an <img> either way until video
348 # support ships.
349 $tvars->{hero_image_1} = $img;
350 }
351 elsif ($surface eq 'cta_label' && length $text) {
352 $tvars->{cta_primary_label} = $text;
353 $tvars->{hero_cta_primary_label} = $text;
354 }
355 elsif ($surface eq 'section_heading' && length $text) {
356 $tvars->{section_heading} = $text;
357 }
358 elsif ($surface eq 'custom' && length $text) {
359 # Stash for layout-level inclusion.
360 $tvars->{experiment_custom_html} = $text;
361 }
362 # surface in (layout|theme|layout_and_theme) is a page-design swap.
363 # Those overrides change the layout_template / theme_css_vars
364 # picked in store.cgi BEFORE this method runs, so there is nothing
365 # to do at the tvar level. See design_overrides_for_assignments().
366 }
367}
368
369# Iterate over @$assignments and collect the merged design overrides
370# from any layout / theme / layout_and_theme variants assigned to this
371# visitor. Returns a hashref { layout_id, theme_id, custom_theme_id }
372# where each field is 0 / undef when not overridden. Used by store.cgi
373# during _resolve_storefront() to swap the page structure / color
374# palette BEFORE the layout template is loaded.
375sub design_overrides_for_assignments {
376 my ($self, $assignments) = @_;
377 my %out = (layout_id => 0, theme_id => 0, custom_theme_id => 0);
378 return \%out unless ref($assignments) eq 'ARRAY';
379
380 foreach my $a (@$assignments) {
381 next unless ref($a) eq 'HASH';
382 my $surface = $a->{surface} || '';
383 next unless $surface eq 'layout'
384 || $surface eq 'theme'
385 || $surface eq 'layout_and_theme';
386 my $v = $a->{variant} or next;
387
388 if ($surface eq 'layout' || $surface eq 'layout_and_theme') {
389 $out{layout_id} = $v->{layout_id} + 0
390 if defined $v->{layout_id} && $v->{layout_id} > 0;
391 }
392 if ($surface eq 'theme' || $surface eq 'layout_and_theme') {
393 $out{theme_id} = $v->{theme_id} + 0
394 if defined $v->{theme_id} && $v->{theme_id} > 0;
395 $out{custom_theme_id} = $v->{custom_theme_id} + 0
396 if defined $v->{custom_theme_id} && $v->{custom_theme_id} > 0;
397 }
398 }
399 return \%out;
400}
401
402#----------------------------------------------------------------------
403# Internal: parse variants JSON
404#----------------------------------------------------------------------
405
406# Parse the variants column we wrote in optimization_action.cgi. The
407# format is fixed (we control both write + read) so a regex is enough
408# without pulling in JSON.pm (no CPAN deps -- see feedback_vanilla_only).
409sub _parse_variants {
410 my ($self, $json) = @_;
411 return () unless defined $json && length $json;
412
413 my @out;
414 # target_model_id is optional -- only present for product_tile
415 # surface experiments. Pre-product_tile rows skip the field entirely
416 # so we make it an optional regex group. layout_id / theme_id /
417 # custom_theme_id are the design-test fields, also optional and only
418 # written when surface is layout / theme / layout_and_theme.
419 # variant_page_id is the storefront_pages.id this variant should
420 # render for, used by surface=storefront_page page-vs-page tests.
421 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+))?(?:,"variant_page_id":(\d+))?(?:,"block_overrides":"((?:[^"\\]|\\.)*)")?\}\}/g) {
422 my ($id, $name, $pct, $target, $text, $img, $lid, $tid, $ctid, $vpid, $blocks)
423 = ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11);
424 for ($name, $text, $img) {
425 s/\\"/"/g;
426 s/\\\\/\\/g;
427 s/\\n/\n/g;
428 s/\\r/\r/g;
429 s/\\t/\t/g;
430 }
431 # block_overrides is itself a stringified JSON blob inside the
432 # variant's "changes" object. Leave it escaped here -- callers
433 # who need the data unescape it via _unjson_str(). Most callers
434 # only need the lookup keys (block ids), parsed downstream.
435 if (defined $blocks) {
436 $blocks =~ s/\\"/"/g;
437 $blocks =~ s/\\\\/\\/g;
438 $blocks =~ s/\\n/\n/g;
439 }
440 push @out, {
441 id => $id,
442 name => $name,
443 traffic_pct => $pct + 0,
444 target_model_id => ($target // 0) + 0,
445 text => $text,
446 image_url => $img,
447 layout_id => ($lid // 0) + 0,
448 theme_id => ($tid // 0) + 0,
449 custom_theme_id => ($ctid // 0) + 0,
450 variant_page_id => ($vpid // 0) + 0,
451 block_overrides => $blocks // '',
452 };
453 }
454 return @out;
455}
456
457# When the visitor is bucketed into a storefront_page A/B variant whose
458# variant_page_id != the base page row, return the id we should render
459# instead of the requested slug. Returns 0 when no override applies.
460# store.cgi calls this after resolving ?page=<slug> -> base page row.
461sub variant_page_id_for_assignments {
462 my ($self, $assignments, $base_page_id) = @_;
463 return 0 unless ref($assignments) eq 'ARRAY' && $base_page_id;
464 $base_page_id += 0;
465 foreach my $a (@$assignments) {
466 next unless ref($a) eq 'HASH';
467 next unless ($a->{surface} || '') eq 'storefront_page';
468 # Each storefront_page experiment is scoped to one base page id
469 # via ab_tests.page_id. Only honour the variant when this
470 # request is for THAT page -- otherwise an unrelated A/B test
471 # on a different page would hijack this render.
472 next unless ($a->{page_id} || 0) == $base_page_id;
473 my $v = $a->{variant} or next;
474 my $vpid = $v->{variant_page_id} || 0;
475 next unless $vpid;
476 return $vpid + 0;
477 }
478 return 0;
479}
480
481# Return the parsed block-override hashref (keyed by block id) for any
482# active page_blocks variant assigned to this visitor for the given
483# base page. Used by store.cgi when rendering a storefront_pages row
484# that has running per-block MVT experiments.
485sub block_overrides_for_assignments {
486 my ($self, $assignments) = @_;
487 my %out;
488 return \%out unless ref($assignments) eq 'ARRAY';
489 foreach my $a (@$assignments) {
490 next unless ref($a) eq 'HASH';
491 next unless ($a->{surface} || '') eq 'page_blocks';
492 my $v = $a->{variant} or next;
493 my $b = $v->{block_overrides} || '';
494 next unless length $b;
495 # Parse "block_id":"value" pairs. We control the writer so the
496 # shape is deterministic: {"block-id":"html or text"} flat map.
497 while ($b =~ /"([^"\\]+)"\s*:\s*"((?:[^"\\]|\\.)*)"/g) {
498 my ($bid, $bval) = ($1, $2);
499 $bval =~ s/\\"/"/g;
500 $bval =~ s/\\\\/\\/g;
501 $bval =~ s/\\n/\n/g;
502 $out{$bid} = $bval;
503 }
504 }
505 return \%out;
506}
507
508#----------------------------------------------------------------------
509# Per-product variant application (surface = product_tile)
510#----------------------------------------------------------------------
511
512# Iterate @$products in-place and apply any product_tile experiment
513# variants whose target_model_id matches a product's id. Used by
514# store.cgi after @products is built but before the template renders.
515sub apply_to_products {
516 my ($self, $assignments, $products) = @_;
517 return unless ref($products) eq 'ARRAY' && ref($assignments) eq 'ARRAY';
518
519 # Build a lookup: model_id -> variant changes (most recent assignment
520 # wins if two experiments somehow target the same product).
521 my %override;
522 foreach my $a (@$assignments) {
523 next unless $a && ($a->{surface} || '') eq 'product_tile';
524 my $v = $a->{variant} or next;
525 my $tid = $v->{target_model_id} || 0;
526 next unless $tid;
527 $override{$tid} = $v;
528 }
529 return unless %override;
530
531 foreach my $p (@$products) {
532 my $pid = $p->{id} || 0;
533 my $v = $override{$pid} or next;
534 if (length($v->{text} || '')) {
535 $p->{title} = $v->{text};
536 }
537 if (length($v->{image_url} || '')) {
538 $p->{hero_image} = $v->{image_url};
539 $p->{hero_image_url} = $v->{image_url};
540 }
541 }
542}
543# ---- Added stubs so /experiments.cgi can render -----------------------
544sub list_for_site {
545 my ($self, $dbh, $DB, $site_id) = @_;
546 return () unless $site_id;
547 my $db = MODS::DBConnect->new;
548 my @rows = $db->db_readwrite_multiple($dbh, qq~
549 SELECT id, site_id, name, description, test_type, status,
550 traffic_pct, target_url_value, primary_metric,
551 winner_variant_id, created_at
552 FROM `${DB}`.ab_tests
553 WHERE site_id='$site_id'
554 ORDER BY id DESC
555 LIMIT 200
556 ~, $ENV{SCRIPT_NAME}, __LINE__);
557 return @rows;
558}
559
560sub get {
561 my ($self, $dbh, $DB, $id) = @_;
562 return undef unless $id;
563 my $db = MODS::DBConnect->new;
564 return $db->db_readwrite($dbh, qq~
565 SELECT * FROM `${DB}`.ab_tests WHERE id='$id' LIMIT 1
566 ~, $ENV{SCRIPT_NAME}, __LINE__);
567}
568
569sub variants_for_test {
570 my ($self, $dbh, $DB, $test_id) = @_;
571 return () unless $test_id;
572 $test_id =~ s/[^0-9]//g;
573 return () unless $test_id;
574 my $db = MODS::DBConnect->new;
575 my @rows = $db->db_readwrite_multiple($dbh, qq~
576 SELECT id, ab_test_id AS test_id, name, is_control, traffic_pct,
577 `changes`, exposures, conversions, revenue_cents, sort_order
578 FROM `${DB}`.ab_variants
579 WHERE ab_test_id='$test_id'
580 ORDER BY sort_order ASC, id ASC
581 ~, $ENV{SCRIPT_NAME}, __LINE__);
582 return @rows;
583}
584
585# ---- Admin CRUD: tests + variants -------------------------------------
586# All quoting is single-quote escape only; column values either come from
587# regex-validated form fields (e.g. enums, numeric ids) or get run through
588# _sqlq for free-text fields. Standard MariaDB '' escape.
589
590sub _sqlq {
591 my $s = shift;
592 return '' unless defined $s;
593 $s =~ s/'/''/g;
594 return $s;
595}
596
597sub create {
598 my ($self, $dbh, $DB, $site_id, $opts) = @_;
599 $opts ||= {};
600 $site_id =~ s/[^0-9]//g if defined $site_id;
601 return 0 unless $site_id;
602
603 my $name = _sqlq(substr($opts->{name} || 'Untitled test', 0, 160));
604 my $desc = _sqlq(substr($opts->{description} || '', 0, 500));
605 my $type = $opts->{test_type} || 'ab';
606 $type = 'ab' unless $type =~ /^(ab|mvt|split_url|redirect|feature_flag)$/;
607 my $match = $opts->{target_url_match} || 'contains';
608 $match = 'contains' unless $match =~ /^(exact|prefix|contains|regex|any)$/;
609 my $url = _sqlq(substr($opts->{target_url_value} || '', 0, 500));
610
611 my $traffic = (defined $opts->{traffic_pct} && $opts->{traffic_pct} =~ /^\d+$/) ? $opts->{traffic_pct} + 0 : 100;
612 $traffic = 100 if $traffic > 100;
613 $traffic = 0 if $traffic < 0;
614
615 my $goal = ($opts->{goal_id} // 0); $goal =~ s/[^0-9]//g if defined $goal;
616 my $goal_sql = $goal ? "'$goal'" : 'NULL';
617
618 my $primary_metric = _sqlq(substr($opts->{primary_metric} || 'conversion_rate', 0, 80));
619
620 my $db = MODS::DBConnect->new;
621 my $r = $db->db_readwrite($dbh, qq~
622 INSERT INTO `${DB}`.ab_tests
623 (site_id, name, description, test_type, target_url_match,
624 target_url_value, traffic_pct, goal_id, primary_metric,
625 status, created_at)
626 VALUES ('$site_id', '$name', '$desc', '$type', '$match',
627 '$url', '$traffic', $goal_sql, '$primary_metric',
628 'draft', NOW())
629 ~, $ENV{SCRIPT_NAME}, __LINE__);
630 my $id = $r ? ($r->{mysql_insertid} || 0) + 0 : 0;
631 return 0 unless $id;
632
633 # Auto-create two starter variants (Control + Variant B) so the test
634 # is immediately editable without forcing the admin to add them by hand.
635 $db->db_readwrite($dbh, qq~
636 INSERT INTO `${DB}`.ab_variants
637 (ab_test_id, name, is_control, traffic_pct, sort_order)
638 VALUES ('$id', 'Control', 1, 50, 0),
639 ('$id', 'Variant B', 0, 50, 1)
640 ~, $ENV{SCRIPT_NAME}, __LINE__);
641
642 return $id;
643}
644
645sub add_variant {
646 my ($self, $dbh, $DB, $test_id, $opts) = @_;
647 $opts ||= {};
648 $test_id =~ s/[^0-9]//g if defined $test_id;
649 return 0 unless $test_id;
650
651 my $name = _sqlq(substr($opts->{name} || 'Variant', 0, 120));
652 my $traffic = (defined $opts->{traffic_pct} && $opts->{traffic_pct} =~ /^\d+$/) ? $opts->{traffic_pct} + 0 : 25;
653 $traffic = 100 if $traffic > 100;
654 $traffic = 0 if $traffic < 0;
655
656 my $db = MODS::DBConnect->new;
657 my $maxp = $db->db_readwrite($dbh, qq~
658 SELECT COALESCE(MAX(sort_order),-1)+1 AS p
659 FROM `${DB}`.ab_variants WHERE ab_test_id='$test_id'
660 ~, $ENV{SCRIPT_NAME}, __LINE__);
661 my $sort = $maxp ? ($maxp->{p} || 0) + 0 : 0;
662
663 my $r = $db->db_readwrite($dbh, qq~
664 INSERT INTO `${DB}`.ab_variants
665 (ab_test_id, name, is_control, traffic_pct, sort_order)
666 VALUES ('$test_id', '$name', 0, '$traffic', '$sort')
667 ~, $ENV{SCRIPT_NAME}, __LINE__);
668 return $r ? ($r->{mysql_insertid} || 0) + 0 : 0;
669}
670
671sub update_variant {
672 my ($self, $dbh, $DB, $variant_id, $opts) = @_;
673 $opts ||= {};
674 $variant_id =~ s/[^0-9]//g if defined $variant_id;
675 return 0 unless $variant_id;
676
677 my @sets;
678 if (defined $opts->{name} && length $opts->{name}) {
679 push @sets, "name='" . _sqlq(substr($opts->{name}, 0, 120)) . "'";
680 }
681 if (defined $opts->{traffic_pct} && $opts->{traffic_pct} =~ /^\d+$/) {
682 my $t = $opts->{traffic_pct} + 0;
683 $t = 100 if $t > 100; $t = 0 if $t < 0;
684 push @sets, "traffic_pct='$t'";
685 }
686 if (defined $opts->{changes}) {
687 push @sets, "`changes`='" . _sqlq($opts->{changes}) . "'";
688 }
689 return 0 unless @sets;
690
691 my $set = join(', ', @sets);
692 my $db = MODS::DBConnect->new;
693 $db->db_readwrite($dbh, qq~
694 UPDATE `${DB}`.ab_variants SET $set WHERE id='$variant_id'
695 ~, $ENV{SCRIPT_NAME}, __LINE__);
696 return 1;
697}
698
699sub delete_variant {
700 my ($self, $dbh, $DB, $variant_id) = @_;
701 $variant_id =~ s/[^0-9]//g if defined $variant_id;
702 return 0 unless $variant_id;
703
704 my $db = MODS::DBConnect->new;
705 # Refuse if this is the only variant left, or it's the control. Tests
706 # need at least one Control variant to function. Empty test = no run.
707 my $r = $db->db_readwrite($dbh, qq~
708 SELECT ab_test_id, is_control FROM `${DB}`.ab_variants
709 WHERE id='$variant_id' LIMIT 1
710 ~, $ENV{SCRIPT_NAME}, __LINE__);
711 return 0 unless $r && $r->{ab_test_id};
712 return 0 if $r->{is_control};
713 my $tid = $r->{ab_test_id} + 0;
714 my $cnt = $db->db_readwrite($dbh, qq~
715 SELECT COUNT(*) AS n FROM `${DB}`.ab_variants WHERE ab_test_id='$tid'
716 ~, $ENV{SCRIPT_NAME}, __LINE__);
717 return 0 if $cnt && $cnt->{n} <= 1;
718
719 $db->db_readwrite($dbh, qq~
720 DELETE FROM `${DB}`.ab_variants WHERE id='$variant_id'
721 ~, $ENV{SCRIPT_NAME}, __LINE__);
722 return 1;
723}
724
725sub delete_test {
726 my ($self, $dbh, $DB, $test_id) = @_;
727 $test_id =~ s/[^0-9]//g if defined $test_id;
728 return 0 unless $test_id;
729
730 my $db = MODS::DBConnect->new;
731 # Cascade: variants + events go too. We use explicit DELETEs instead of
732 # FK ON DELETE CASCADE since the schema doesn't declare FKs on these.
733 $db->db_readwrite($dbh, qq~DELETE FROM `${DB}`.ab_variants WHERE ab_test_id='$test_id'~, $ENV{SCRIPT_NAME}, __LINE__);
734 $db->db_readwrite($dbh, qq~DELETE FROM `${DB}`.ab_test_events WHERE ab_test_id='$test_id'~, $ENV{SCRIPT_NAME}, __LINE__);
735 $db->db_readwrite($dbh, qq~DELETE FROM `${DB}`.ab_tests WHERE id='$test_id'~, $ENV{SCRIPT_NAME}, __LINE__);
736 return 1;
737}
738
739sub start {
740 my ($self, $dbh, $DB, $test_id) = @_;
741 $test_id =~ s/[^0-9]//g if defined $test_id;
742 return 0 unless $test_id;
743 my $db = MODS::DBConnect->new;
744 # Refuse to start if there are no variants yet, OR no control variant.
745 my $r = $db->db_readwrite($dbh, qq~
746 SELECT COUNT(*) AS n, SUM(is_control) AS controls
747 FROM `${DB}`.ab_variants WHERE ab_test_id='$test_id'
748 ~, $ENV{SCRIPT_NAME}, __LINE__);
749 return 0 unless $r && $r->{n} && $r->{n} >= 2 && $r->{controls} >= 1;
750 # Set started_at only on the first start (preserve original start when
751 # toggling pause/resume).
752 $db->db_readwrite($dbh, qq~
753 UPDATE `${DB}`.ab_tests
754 SET status='running',
755 started_at = COALESCE(started_at, NOW()),
756 stopped_at = NULL
757 WHERE id='$test_id'
758 ~, $ENV{SCRIPT_NAME}, __LINE__);
759 return 1;
760}
761
762sub pause {
763 my ($self, $dbh, $DB, $test_id) = @_;
764 $test_id =~ s/[^0-9]//g if defined $test_id;
765 return 0 unless $test_id;
766 my $db = MODS::DBConnect->new;
767 $db->db_readwrite($dbh, qq~
768 UPDATE `${DB}`.ab_tests SET status='paused' WHERE id='$test_id'
769 ~, $ENV{SCRIPT_NAME}, __LINE__);
770 return 1;
771}
772
773sub stop {
774 my ($self, $dbh, $DB, $test_id, $winner_variant_id) = @_;
775 $test_id =~ s/[^0-9]//g if defined $test_id;
776 return 0 unless $test_id;
777 my $winner_sql = 'NULL';
778 if (defined $winner_variant_id) {
779 $winner_variant_id =~ s/[^0-9]//g;
780 $winner_sql = $winner_variant_id ? "'$winner_variant_id'" : 'NULL';
781 }
782 my $db = MODS::DBConnect->new;
783 $db->db_readwrite($dbh, qq~
784 UPDATE `${DB}`.ab_tests
785 SET status='complete',
786 stopped_at=NOW(),
787 winner_variant_id=$winner_sql
788 WHERE id='$test_id'
789 ~, $ENV{SCRIPT_NAME}, __LINE__);
790 return 1;
791}
792
793# Wraps the existing _p_b_beats_a for use from experiments.cgi.
794# Takes (control_exposures, control_conversions, variant_exposures, variant_conversions)
795# and returns P(variant beats control) in [0, 1].
796sub significance {
797 my ($self, $exp_a, $conv_a, $exp_b, $conv_b) = @_;
798 $exp_a ||= 0; $conv_a ||= 0; $exp_b ||= 0; $conv_b ||= 0;
799 return 0 if ($exp_a + $exp_b) < 1;
800 return $self->_p_b_beats_a($conv_a, $exp_a, $conv_b, $exp_b);
801}
802
8031;
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help