Diff -- /var/www/vhosts/3dshawn.com/ptmatrix.3dshawn.com/track.cgi
Diff

/var/www/vhosts/3dshawn.com/ptmatrix.3dshawn.com/track.cgi

added on local at 2026-07-01 12:35:16

Added
+225
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to 8b199e4b0284
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##################################################################################################################################
4# ______ ____ ____ ______ ______ ____ ___ __ ___ ______ _ __ ____ ____ __ __ _ __ _____ ____
5# / ____// __ \ / __ \ / ____/ / ____// __ \ / | / |/ // ____/| | / // __ \ / __ \ / //_/ | | / /|__ / / __ \
6# / / / / / // / / // __/ / /_ / /_/ // /| | / /|_/ // __/ | | /| / // / / // /_/ // ,< | | / / /_ < / / / /
7# / /___ / /_/ // /_/ // /___ / __/ / _, _// ___ | / / / // /___ | |/ |/ // /_/ // _, _// /| | | |/ / ___/ /_ / /_/ /
8# \____/ \____//_____//_____/ /_/ /_/ |_|/_/ |_|/_/ /_//_____/ |__/|__/ \____//_/ |_|/_/ |_| |___/ /____/(_)\____/
9#
10# - Written by: Shawn Pickering
11# - shawn@shawnpickering.com
12##################################################################################################################################
13use strict;
14use lib '/var/www/vhosts/3dshawn.com/ptmatrix.3dshawn.com';
15
16
17#############################################################
18## Variables
19#############################################################
20#Slurp the raw JSON body BEFORE loading CGI - CGI.pm's new() consumes STDIN on POST,
21#and per Shawn's rule we always slurp ourselves first so the body lands intact.
22our $BODY = '';
23if(($ENV{REQUEST_METHOD} || '') eq 'POST'){
24 my $len = $ENV{CONTENT_LENGTH} || 0;
25 $len = 0 if $len !~ /^\d+$/;
26 $len = 1_000_000 if $len > 1_000_000;
27 read(STDIN, $BODY, $len) if $len > 0;
28}
29
30
31
32############################################################
33# Modules
34############################################################
35use MODS::DBConnect; my $db = new MODS::DBConnect;
36use MODS::PTMatrix::Config; my $config = new MODS::PTMatrix::Config; my $database_name = $config->settings('database_name');
37use MODS::PTMatrix::Tracking; my $tr = new MODS::PTMatrix::Tracking;
38
39
40
41############################################################
42# Program Controls
43############################################################
44$|=1;
45if(($ENV{QUERY_STRING} || '') =~ /(?:^|&)debug=stats(?:&|$)/){&debug_stats;}
46else{&ingest;}
47
48
49############################################################
50# Subroutines
51############################################################
52sub emit_json{
53 my($h) = @_;
54 print qq~Content-Type: application/json\nCache-Control: no-store\n\n~;
55 my @pairs;
56 foreach my $k(sort keys %$h){
57 my $v = $h->{$k};
58 my $val;
59 if (!defined $v) {$val = 'null';}
60 elsif($v =~ /^-?\d+$/) {$val = $v;}
61 else{
62 $v =~ s/\\/\\\\/g; $v =~ s/"/\\"/g; $v =~ s/\n/\\n/g; $v =~ s/\r/\\r/g;
63 $val = qq~"$v"~;
64 }
65 push @pairs, qq~"$k":$val~;
66 }
67 print '{' . join(',', @pairs) . '}';
68 exit;
69}
70
71sub parse_flat_json{
72 my($s) = @_;
73 return () unless defined $s && length $s;
74 my %out;
75 $s =~ s/^\s*\{//;
76 $s =~ s/\}\s*$//;
77 while($s =~ /"([a-zA-Z0-9_]+)"\s*:\s*(?:"((?:[^"\\]|\\.)*)"|(true|false|null|-?\d+(?:\.\d+)?))/g){
78 my $key = $1;
79 my $val = defined $2 ? $2 : $3;
80 if(defined $2){
81 $val =~ s/\\n/\n/g; $val =~ s/\\r/\r/g; $val =~ s/\\"/"/g; $val =~ s/\\\\/\\/g;
82 }
83 $val = '' if defined $val && $val eq 'null';
84 $out{$key} = $val;
85 }
86 return %out;
87}
88
89sub debug_stats{
90 #GET /track.cgi?debug=stats - counts of tracking rows for quick health check
91 my $dbh = $db->db_connect();
92 my $ready = $tr->schema_ready($db, $dbh, $database_name) ? 1 : 0;
93
94 my ($sessions, $events, $last_seen) = (0, 0, '');
95 if($ready){
96 my $s = $db->db_readwrite($dbh, qq~SELECT COUNT(*) AS n FROM `${database_name}`.tracking_sessions~, $ENV{SCRIPT_NAME}, __LINE__);
97 $sessions = $s->{n} || 0;
98 my $e = $db->db_readwrite($dbh, qq~SELECT COUNT(*) AS n FROM `${database_name}`.tracking_events~, $ENV{SCRIPT_NAME}, __LINE__);
99 $events = $e->{n} || 0;
100 my $l = $db->db_readwrite($dbh, qq~SELECT MAX(last_seen_at) AS t FROM `${database_name}`.tracking_sessions~, $ENV{SCRIPT_NAME}, __LINE__);
101 $last_seen = $l->{t} || '';
102 }
103 $db->db_disconnect($dbh);
104
105 print qq~Content-Type: application/json\nCache-Control: no-store\n\n~;
106 print qq~{"ok":1,"schema_ready":$ready,"sessions":$sessions,"events":$events,"last_seen":"$last_seen"}~;
107}
108
109#Resolve current user + company from the taskforge_session cookie.
110#Skip the full revoked/expired dance login_verify does - the worst case for
111#a forged cookie here is a wrong user_id stamp on the visitor row.
112sub resolve_cookie_user{
113 my($dbh) = @_;
114 my $cookies = $ENV{HTTP_COOKIE} || '';
115 my $sess_token;
116 if($cookies =~ /(?:^|;\s*)taskforge_session=([A-Za-z0-9\-]+)/){
117 $sess_token = $1;
118 }
119 return (undef, undef) unless $sess_token;
120
121 my $st = $sess_token; $st =~ s/[^A-Za-z0-9\-]//g; $st = substr($st, 0, 80);
122 my $r = $db->db_readwrite($dbh, qq~SELECT u.id AS user_id, u.company_id FROM `${database_name}`.user_sessions s JOIN `${database_name}`.users u ON u.id = s.user_id WHERE s.id='$st' AND s.revoked_at IS NULL AND s.expires_at > NOW() LIMIT 1~, $ENV{SCRIPT_NAME}, __LINE__);
123 if($r && $r->{user_id}){
124 return ($r->{user_id}, $r->{company_id} || '');
125 }
126 return (undef, undef);
127}
128
129sub ingest{
130 my %payload = &parse_flat_json($BODY);
131
132 my $token = $payload{token} || '';
133 $token =~ s/[^a-f0-9-]//g;
134
135 my $ip = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR} || '';
136 $ip =~ s/,.*$//;
137 $ip =~ s/^\s+|\s+$//g;
138
139 my $dbh = $db->db_connect();
140 if(!$tr->schema_ready($db, $dbh, $database_name)){
141 $db->db_disconnect($dbh);
142 &emit_json({ ok => 0, err => 'schema_not_installed' });
143 }
144
145 my ($cookie_uid, $cookie_company) = &resolve_cookie_user($dbh);
146
147 my $kind = $payload{kind} || '';
148 my $result = { ok => 1 };
149
150 if($kind eq 'init'){
151 if(length $token != 36){
152 $db->db_disconnect($dbh);
153 &emit_json({ ok => 0, err => 'bad_token' });
154 }
155
156 my $existing = $tr->session_by_token($db, $dbh, $database_name, $token);
157 my $sid;
158 if($existing && $existing->{id}){
159 $sid = $existing->{id};
160 $tr->heartbeat($db, $dbh, $database_name, $sid, $payload{page});
161 #Late login binding - visitor signed in after their row was minted
162 if($cookie_uid && !$existing->{user_id}){
163 $tr->link_session_to_user($db, $dbh, $database_name, $token, $cookie_uid, $cookie_company);
164 }
165 }else{
166 my $ua_parsed = $tr->parse_ua($ENV{HTTP_USER_AGENT}) || {};
167 $sid = $tr->create_session($db, $dbh, $database_name,
168 session_token => $token,
169 ip_address => $ip,
170 user_agent => $ENV{HTTP_USER_AGENT},
171 referrer => $payload{referrer},
172 current_page_path => $payload{page},
173 user_id => $cookie_uid,
174 company_id => $cookie_company,
175 os_name => $payload{os_name} || $ua_parsed->{os_name},
176 os_version => $payload{os_version} || $ua_parsed->{os_version},
177 browser_name => $payload{browser_name} || $ua_parsed->{browser_name},
178 browser_version => $payload{browser_version} || $ua_parsed->{browser_version},
179 device_type => $payload{device_type} || $ua_parsed->{device_type},
180 screen_w => $payload{screen_w},
181 screen_h => $payload{screen_h},
182 viewport_w => $payload{viewport_w},
183 viewport_h => $payload{viewport_h},
184 color_depth => $payload{color_depth},
185 pixel_ratio => $payload{pixel_ratio},
186 touch_capable => $payload{touch_capable},
187 language => $payload{language},
188 timezone => $payload{timezone},
189 );
190 }
191 $result->{session_id} = $sid;
192 }elsif($kind eq 'event'){
193 my $sess = $tr->session_by_token($db, $dbh, $database_name, $token);
194 if(!$sess || !$sess->{id}){
195 $db->db_disconnect($dbh);
196 &emit_json({ ok => 0, err => 'no_session' });
197 }
198
199 #Late-login binding - stitch anon browser -> signed-in user on next event fire
200 if($cookie_uid && !$sess->{user_id}){
201 $tr->link_session_to_user($db, $dbh, $database_name, $token, $cookie_uid, $cookie_company);
202 }
203 $tr->heartbeat($db, $dbh, $database_name, $sess->{id}, $payload{page});
204 $tr->log_event($db, $dbh, $database_name,
205 session_id => $sess->{id},
206 company_id => $cookie_company || $sess->{company_id},
207 event_type => $payload{type} || 'page_view',
208 page_path => $payload{page},
209 element_selector => $payload{selector},
210 x_pct => $payload{x_pct},
211 y_pct => $payload{y_pct},
212 offset_x_pct => $payload{offset_x_pct},
213 offset_y_pct => $payload{offset_y_pct},
214 scroll_pct => $payload{scroll_pct},
215 metadata => $payload{metadata},
216 );
217 $result->{session_id} = $sess->{id};
218 }else{
219 $db->db_disconnect($dbh);
220 &emit_json({ ok => 0, err => 'bad_kind' });
221 }
222
223 $db->db_disconnect($dbh);
224 &emit_json($result);
225}
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help