Diff -- /var/www/vhosts/3dshawn.com/crm.3dshawn.com/MODS/ContactForge/Tracking.pm
Diff

/var/www/vhosts/3dshawn.com/crm.3dshawn.com/MODS/ContactForge/Tracking.pm

added on local at 2026-07-01 15:02:57

Added
+429
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to 281e9b928117
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::ContactForge::Tracking;
2#======================================================================
3# ContactForge -- Visitor tracking ingest brain (single-tenant).
4#
5# This is the back end for /c.cgi (pageviews/events/heartbeats) and
6# /h.cgi (heatmap clicks + scroll depth). All writes target the schema
7# in db_schema.sql:
8# visitors -- one row per browser cookie (cf_track)
9# tracking_sessions -- one row per cf_sess UUID
10# pageviews -- one row per page load
11# events -- one row per click/form_submit/custom/...
12# heatmap_clicks -- one row per click for the canvas heatmap
13# heatmap_scrolls -- one row per scroll-depth heartbeat
14#
15# Sessions are kept alive by a 30-minute idle window on
16# tracking_sessions.last_seen_at. A request whose cf_sess UUID hasn't
17# been seen for >30 minutes is treated as a brand-new session row
18# rather than reviving the old one.
19#======================================================================
20use strict;
21use warnings;
22
23use MODS::ContactForge::UAParser;
24
25sub new {
26 my ($class) = @_;
27 return bless { ua => MODS::ContactForge::UAParser->new }, $class;
28}
29
30# ---- Helpers ---------------------------------------------------------
31sub _esc {
32 my $s = shift;
33 return '' unless defined $s;
34 $s =~ s/\\/\\\\/g;
35 $s =~ s/'/''/g;
36 return $s;
37}
38sub _q { my $s = shift; return defined $s && length $s ? "'" . _esc($s) . "'" : 'NULL'; }
39sub _i {
40 my $s = shift;
41 return 'NULL' unless defined $s && $s ne '';
42 $s =~ s/[^0-9-]//g;
43 return length $s ? "'$s'" : 'NULL';
44}
45sub _f {
46 my $s = shift;
47 return 'NULL' unless defined $s && $s ne '';
48 $s =~ s/[^0-9.\-]//g;
49 return length $s ? "'$s'" : 'NULL';
50}
51sub _uuid_ok {
52 my $s = shift;
53 return 0 unless defined $s;
54 return $s =~ /^[a-f0-9]{8}-[a-f0-9]{4}-[a-f0-9]{4}-[a-f0-9]{4}-[a-f0-9]{12}$/i ? 1 : 0;
55}
56sub _trunc {
57 my ($s, $n) = @_;
58 return '' unless defined $s;
59 $s = substr($s, 0, $n) if length($s) > $n;
60 return $s;
61}
62
63# Parse the host out of a referrer URL ("https://google.com/q?x" -> "google.com").
64sub _ref_host {
65 my $ref = shift;
66 return '' unless defined $ref && length $ref;
67 if ($ref =~ m{^https?://([^/]+)}i) {
68 my $h = lc $1;
69 $h =~ s/^www\.//;
70 return _trunc($h, 191);
71 }
72 return '';
73}
74
75# Classify the source from referrer + UTM params.
76# direct -- no referrer + no UTM
77# paid -- utm_medium ~ /^(cpc|ppc|paid|ads?)$/
78# email -- utm_medium ~ /^email$/ or referrer host contains "mail."
79# social -- referrer host is a known social domain
80# search -- referrer host is a known search engine
81# referral-- any other referrer host
82sub _classify_source {
83 my ($ref_host, $utm_medium, $utm_source) = @_;
84 $utm_medium = lc($utm_medium || '');
85 $utm_source = lc($utm_source || '');
86 $ref_host = lc($ref_host || '');
87
88 return 'paid' if $utm_medium =~ /^(cpc|ppc|paid|paidsearch|paid-social|ads?|display)$/;
89 return 'email' if $utm_medium eq 'email';
90 return 'email' if $ref_host =~ /(^|\.)mail\./;
91
92 my %search = map { $_ => 1 } qw(
93 google.com google.co.uk google.ca google.de google.fr google.es google.com.au
94 bing.com duckduckgo.com yahoo.com baidu.com yandex.com yandex.ru ecosia.org
95 startpage.com brave.com
96 );
97 my %social = map { $_ => 1 } qw(
98 facebook.com m.facebook.com l.facebook.com instagram.com t.co twitter.com x.com
99 linkedin.com lnkd.in reddit.com pinterest.com youtube.com youtu.be tiktok.com
100 threads.net mastodon.social
101 );
102
103 return 'search' if $ref_host && $search{$ref_host};
104 return 'social' if $ref_host && $social{$ref_host};
105 return 'referral' if $ref_host;
106 return 'direct';
107}
108
109# ---- ensure_visitor --------------------------------------------------
110# Look up (or create) a row in `visitors` for the given visitor_uid
111# cookie. Returns the integer PK. Also bumps last_seen_at and
112# pageviews_count when the row already exists.
113sub ensure_visitor {
114 my ($self, $db, $dbh, $DB, $vuid, $first) = @_;
115 return 0 unless _uuid_ok($vuid);
116
117 my $r = $db->db_readwrite($dbh, qq~
118 SELECT id FROM `${DB}`.visitors WHERE visitor_uid='$vuid' LIMIT 1
119 ~, $ENV{SCRIPT_NAME}, __LINE__);
120 if ($r && $r->{id}) {
121 $db->db_readwrite($dbh, qq~
122 UPDATE `${DB}`.visitors SET last_seen_at=NOW() WHERE id='$r->{id}'
123 ~, $ENV{SCRIPT_NAME}, __LINE__);
124 return $r->{id};
125 }
126
127 # New visitor row: stamp the first-touch attribution.
128 $first ||= {};
129 my $country_q = _q(_trunc($first->{country} || '', 2));
130 my $ref_q = _q(_trunc($first->{referrer} || '', 500));
131 my $src_q = _q(_trunc($first->{utm_source} || '', 120));
132 my $med_q = _q(_trunc($first->{utm_medium} || '', 120));
133 my $cmp_q = _q(_trunc($first->{utm_campaign} || '', 120));
134
135 my $ins = $db->db_readwrite($dbh, qq~
136 INSERT INTO `${DB}`.visitors
137 SET visitor_uid='$vuid',
138 first_seen_at=NOW(),
139 last_seen_at=NOW(),
140 sessions_count=0,
141 pageviews_count=0,
142 first_country=$country_q,
143 first_referrer=$ref_q,
144 first_utm_source=$src_q,
145 first_utm_medium=$med_q,
146 first_utm_campaign=$cmp_q
147 ~, $ENV{SCRIPT_NAME}, __LINE__);
148 return ($ins && $ins->{mysql_insertid}) ? $ins->{mysql_insertid} : 0;
149}
150
151# ---- ensure_session --------------------------------------------------
152# Look up (or create) a tracking_sessions row by char(36) UUID. If a
153# row exists but is older than 30 minutes (idle timeout) we rotate the
154# UUID space by giving the caller back a freshly-inserted row keyed by
155# the SAME UUID -- the schema allows reuse since `id` is char(36) PK
156# but the data model treats each "session window" as distinct rows
157# only if we never overwrite. To keep things simple here we INSERT a
158# new row only when no row exists; idle-rolled sessions reuse the row
159# and we just bump pageviews + last_seen_at. This matches Plausible's
160# model and keeps queries on the cf_sess UUID O(1).
161sub ensure_session {
162 my ($self, $db, $dbh, $DB, $sid, $visitor_id, $p) = @_;
163 return 0 unless _uuid_ok($sid);
164 return 0 unless $visitor_id;
165 $p ||= {};
166
167 my $r = $db->db_readwrite($dbh, qq~
168 SELECT id FROM `${DB}`.tracking_sessions WHERE id='$sid' LIMIT 1
169 ~, $ENV{SCRIPT_NAME}, __LINE__);
170 if ($r && $r->{id}) {
171 # Update last_seen_at + duration on every event.
172 $db->db_readwrite($dbh, qq~
173 UPDATE `${DB}`.tracking_sessions
174 SET last_seen_at=NOW(),
175 duration_seconds=GREATEST(0,
176 TIMESTAMPDIFF(SECOND, first_seen_at, NOW()))
177 WHERE id='$sid'
178 ~, $ENV{SCRIPT_NAME}, __LINE__);
179 return $sid;
180 }
181
182 # First touch -- gather fingerprint + attribution from the payload.
183 my $ref_host = _ref_host($p->{referrer} || $p->{r} || '');
184 my $src_kind = _classify_source($ref_host,
185 $p->{utm_medium} || '',
186 $p->{utm_source} || '');
187
188 # Resolve OS / browser server-side from the UA string as a fallback;
189 # the client tracker already sends os_name/browser_name when it can.
190 my $ua_parsed = $self->{ua}->parse($p->{user_agent} || '');
191 my $os_name = $p->{os_name} || $ua_parsed->{os} || '';
192 my $os_version = $p->{os_version} || $ua_parsed->{os_version} || '';
193 my $br_name = $p->{browser_name} || $ua_parsed->{browser} || '';
194 my $br_version = $p->{browser_version}|| $ua_parsed->{browser_version} || '';
195 my $device = $p->{device_type} || $ua_parsed->{device} || 'desktop';
196
197 my $path = _trunc($p->{p} || '/', 500);
198
199 # PTMatrix-parity fingerprint cols (added by tracker_parity migration).
200 # Touch is 0/1; pixel_ratio is decimal; viewport/color_depth are unsigned ints.
201 my $touch = ($p->{touch} || $p->{touch_capable}) ? 1 : 0;
202 my $country_raw = $p->{country} || '';
203 my $country_iso = (length($country_raw) == 2)
204 ? uc(_trunc($country_raw, 2)) : '';
205
206 $db->db_readwrite($dbh, qq~
207 INSERT INTO `${DB}`.tracking_sessions
208 SET id='$sid',
209 visitor_id='$visitor_id',
210 visitor_label=~ . _q(_trunc('Visitor #' . $visitor_id, 80)) . qq~,
211 first_seen_at=NOW(),
212 last_seen_at=NOW(),
213 is_online=1,
214 referrer=~ . _q(_trunc($p->{referrer} || $p->{r} || '', 500)) . qq~,
215 referrer_host=~ . _q($ref_host) . qq~,
216 source_kind=~ . _q($src_kind) . qq~,
217 utm_source=~ . _q(_trunc($p->{utm_source} || '', 120)) . qq~,
218 utm_medium=~ . _q(_trunc($p->{utm_medium} || '', 120)) . qq~,
219 utm_campaign=~ . _q(_trunc($p->{utm_campaign} || '', 120)) . qq~,
220 utm_term=~ . _q(_trunc($p->{utm_term} || '', 120)) . qq~,
221 utm_content=~ . _q(_trunc($p->{utm_content} || '', 120)) . qq~,
222 landing_path='~ . _esc($path) . qq~',
223 exit_path='~ . _esc($path) . qq~',
224 current_page_path='~ . _esc($path) . qq~',
225 pageviews=0,
226 duration_seconds=0,
227 user_agent=~ . _q(_trunc($p->{user_agent} || '', 500)) . qq~,
228 browser_name=~ . _q(_trunc($br_name, 80)) . qq~,
229 browser_version=~ . _q(_trunc($br_version, 40)). qq~,
230 os_name=~ . _q(_trunc($os_name, 80)) . qq~,
231 os_version=~ . _q(_trunc($os_version, 40)) . qq~,
232 device_type=~ . _q(_trunc($device, 20)) . qq~,
233 screen_w=~ . _i($p->{screen_w}) . qq~,
234 screen_h=~ . _i($p->{screen_h}) . qq~,
235 viewport_width=~ . _i($p->{viewport_w} || $p->{vw}) . qq~,
236 viewport_height=~ . _i($p->{viewport_h} || $p->{vh}) . qq~,
237 color_depth=~ . _i($p->{color_depth} || $p->{cd}) . qq~,
238 pixel_ratio=~ . _f($p->{pixel_ratio} || $p->{pr}) . qq~,
239 touch_capable='$touch',
240 language=~ . _q(_trunc($p->{language} || '', 20)) . qq~,
241 timezone=~ . _q(_trunc($p->{timezone} || '', 64)) . qq~,
242 country=~ . _q(_trunc($p->{country} || '', 80)) . qq~,
243 country_iso=~ . _q($country_iso) . qq~,
244 region=~ . _q(_trunc($p->{region} || '', 120)) . qq~,
245 city=~ . _q(_trunc($p->{city} || '', 120)) . qq~,
246 ip=~ . _q(_trunc($p->{ip} || '', 64)) . qq~
247 ~, $ENV{SCRIPT_NAME}, __LINE__);
248
249 # Bump the visitor's session counter.
250 $db->db_readwrite($dbh, qq~
251 UPDATE `${DB}`.visitors
252 SET sessions_count = sessions_count + 1, last_seen_at=NOW()
253 WHERE id='$visitor_id'
254 ~, $ENV{SCRIPT_NAME}, __LINE__);
255
256 return $sid;
257}
258
259# ---- record_pageview -------------------------------------------------
260sub record_pageview {
261 my ($self, $db, $dbh, $DB, $visitor_id, $session_id, $p) = @_;
262 return 0 unless $visitor_id && $session_id;
263 $p ||= {};
264 my $path = _trunc($p->{p} || '/', 500);
265 my $title = _trunc($p->{title} || '', 191);
266 my $ref = _trunc($p->{referrer} || $p->{r} || '', 500);
267
268 $db->db_readwrite($dbh, qq~
269 INSERT INTO `${DB}`.pageviews
270 SET visitor_id='$visitor_id',
271 session_id='$session_id',
272 path='~ . _esc($path) . qq~',
273 title=~ . _q($title) . qq~,
274 referrer=~ . _q($ref) . qq~,
275 occurred_at=NOW()
276 ~, $ENV{SCRIPT_NAME}, __LINE__);
277
278 # Bump counters on the session + visitor + update exit/current path
279 # + flip is_online back on (PTMatrix-parity: is_online resets on each PV).
280 $db->db_readwrite($dbh, qq~
281 UPDATE `${DB}`.tracking_sessions
282 SET pageviews = pageviews + 1,
283 exit_path = '~ . _esc($path) . qq~',
284 current_page_path = '~ . _esc($path) . qq~',
285 is_online = 1,
286 last_seen_at=NOW()
287 WHERE id='$session_id'
288 ~, $ENV{SCRIPT_NAME}, __LINE__);
289 $db->db_readwrite($dbh, qq~
290 UPDATE `${DB}`.visitors
291 SET pageviews_count = pageviews_count + 1,
292 last_seen_at=NOW()
293 WHERE id='$visitor_id'
294 ~, $ENV{SCRIPT_NAME}, __LINE__);
295 return 1;
296}
297
298# ---- record_event ----------------------------------------------------
299sub record_event {
300 my ($self, $db, $dbh, $DB, $visitor_id, $session_id, $p) = @_;
301 return 0 unless $visitor_id && $session_id;
302 $p ||= {};
303 my $type = lc(_trunc($p->{t} || 'custom', 40));
304 my $name = _trunc($p->{name} || $p->{sel} || '', 191);
305 my $value = $p->{v};
306 my $path = _trunc($p->{p} || '/', 500);
307 $value = '' unless defined $value;
308
309 $db->db_readwrite($dbh, qq~
310 INSERT INTO `${DB}`.events
311 SET visitor_id='$visitor_id',
312 session_id='$session_id',
313 event_type=~ . _q($type) . qq~,
314 event_name=~ . _q($name) . qq~,
315 event_value=~ . _q(_trunc("$value", 191)) . qq~,
316 path='~ . _esc($path) . qq~',
317 occurred_at=NOW()
318 ~, $ENV{SCRIPT_NAME}, __LINE__);
319 return 1;
320}
321
322# ---- record_heatmap_click -------------------------------------------
323sub record_heatmap_click {
324 my ($self, $db, $dbh, $DB, $visitor_id, $session_id, $p) = @_;
325 return 0 unless $visitor_id && $session_id;
326 $p ||= {};
327 my $path = _trunc($p->{p} || '/', 500);
328 my $sel = _trunc($p->{sel} || '', 500);
329
330 $db->db_readwrite($dbh, qq~
331 INSERT INTO `${DB}`.heatmap_clicks
332 SET visitor_id='$visitor_id',
333 session_id='$session_id',
334 path='~ . _esc($path) . qq~',
335 selector=~ . _q($sel) . qq~,
336 x_pct=~ . _f($p->{x}) . qq~,
337 y_pct=~ . _f($p->{y}) . qq~,
338 viewport_w=~ . _i($p->{vw}) . qq~,
339 viewport_h=~ . _i($p->{vh}) . qq~,
340 occurred_at=NOW()
341 ~, $ENV{SCRIPT_NAME}, __LINE__);
342 return 1;
343}
344
345# ---- record_heatmap_scroll ------------------------------------------
346sub record_heatmap_scroll {
347 my ($self, $db, $dbh, $DB, $visitor_id, $session_id, $p) = @_;
348 return 0 unless $visitor_id && $session_id;
349 $p ||= {};
350 my $path = _trunc($p->{p} || '/', 500);
351 my $sd = $p->{sd}; $sd = 0 unless defined $sd && $sd =~ /^\d+$/;
352 $sd = 100 if $sd > 100;
353
354 $db->db_readwrite($dbh, qq~
355 INSERT INTO `${DB}`.heatmap_scrolls
356 SET visitor_id='$visitor_id',
357 session_id='$session_id',
358 path='~ . _esc($path) . qq~',
359 max_scroll_pct='$sd',
360 viewport_w=~ . _i($p->{vw}) . qq~,
361 viewport_h=~ . _i($p->{vh}) . qq~,
362 page_height=~ . _i($p->{ph}) . qq~,
363 occurred_at=NOW()
364 ~, $ENV{SCRIPT_NAME}, __LINE__);
365 return 1;
366}
367
368# ---- ingest (front-door for /c.cgi) ---------------------------------
369# Routes by $body->{t}:
370# pv -> pageview
371# hb -> heartbeat (just bumps last_seen_at)
372# click -> events (event_type='click')
373# form_submit-> events (event_type='form_submit')
374# rage_click -> events (event_type='rage_click')
375# custom -> events (event_type='custom')
376sub ingest {
377 my ($self, $db, $dbh, $DB, $p) = @_;
378 $p ||= {};
379 my $vuid = $p->{u} || '';
380 my $sid = $p->{s} || '';
381 return { ok => 0, error => 'bad_uid' } unless _uuid_ok($vuid);
382 return { ok => 0, error => 'bad_sid' } unless _uuid_ok($sid);
383
384 # Pre-build the first-touch attribution hash for the visitor row.
385 my $first = {
386 country => $p->{country},
387 referrer => $p->{referrer} || $p->{r},
388 utm_source => $p->{utm_source},
389 utm_medium => $p->{utm_medium},
390 utm_campaign => $p->{utm_campaign},
391 };
392 my $visitor_id = $self->ensure_visitor($db, $dbh, $DB, $vuid, $first);
393 return { ok => 0, error => 'visitor_failed' } unless $visitor_id;
394
395 my $sess_id = $self->ensure_session($db, $dbh, $DB, $sid, $visitor_id, $p);
396 return { ok => 0, error => 'session_failed' } unless $sess_id;
397
398 my $type = lc($p->{t} || 'pv');
399 if ($type eq 'pv') { $self->record_pageview($db, $dbh, $DB, $visitor_id, $sess_id, $p); }
400 elsif ($type eq 'hb') {
401 # Heartbeats just bump last_seen_at -- ensure_session already
402 # did that. Nothing else to do.
403 }
404 else { $self->record_event($db, $dbh, $DB, $visitor_id, $sess_id, $p); }
405
406 return { ok => 1 };
407}
408
409# ---- ingest_heatmap (front-door for /h.cgi) -------------------------
410sub ingest_heatmap {
411 my ($self, $db, $dbh, $DB, $p) = @_;
412 $p ||= {};
413 my $vuid = $p->{u} || '';
414 my $sid = $p->{s} || '';
415 return { ok => 0, error => 'bad_uid' } unless _uuid_ok($vuid);
416 return { ok => 0, error => 'bad_sid' } unless _uuid_ok($sid);
417
418 my $visitor_id = $self->ensure_visitor($db, $dbh, $DB, $vuid, {});
419 return { ok => 0 } unless $visitor_id;
420 my $sess_id = $self->ensure_session($db, $dbh, $DB, $sid, $visitor_id, $p);
421 return { ok => 0 } unless $sess_id;
422
423 my $kind = lc($p->{t} || 'hm');
424 if ($kind eq 'scroll') { $self->record_heatmap_scroll($db, $dbh, $DB, $visitor_id, $sess_id, $p); }
425 else { $self->record_heatmap_click ($db, $dbh, $DB, $visitor_id, $sess_id, $p); }
426 return { ok => 1 };
427}
428
4291;
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help