Diff -- /var/www/vhosts/3dshawn.com/affiliate.3dshawn.com/MODS/AffSoft/Experiments.pm
Diff

/var/www/vhosts/3dshawn.com/affiliate.3dshawn.com/MODS/AffSoft/Experiments.pm

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

Added
+544
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to 52b45b0e7cf7
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::AffSoft::Experiments;
2#======================================================================
3# WebSTLs -- 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 (webstls_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 webstls_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('webstls_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~webstls_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
5441;
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help