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

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

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

Added
+166
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to d0a315876ee9
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#1x1 transparent GIF (43 bytes) returned on every hit
21my $PIXEL_HEX = '47494638396101000100800000ffffff00000021f90401000001002c00000000010001000002024401003b';
22
23
24
25############################################################
26# Modules
27############################################################
28use CGI; my $query = new CGI;
29use MODS::DBConnect; my $db = new MODS::DBConnect;
30use MODS::PTMatrix::Config; my $config = new MODS::PTMatrix::Config; my $database_name = $config->settings('database_name');
31use Digest::SHA qw(sha1_hex);
32
33
34
35############################################################
36# Program Controls
37############################################################
38$|=1;
39&track;
40
41
42############################################################
43# Subroutines
44############################################################
45sub track{
46 #Anonymous pageview tracker. Skipped silently when:
47 # - the request carries a logged-in session cookie (we don't track auth users)
48 # - the User-Agent matches a known bot pattern
49 # Drops the tf_a session cookie on first hit, then appends to anon_pageviews
50
51 #Skip if there's a real login cookie - we only care about anon visitor paths
52 my $auth_cookie = $query->cookie('taskforge_session') || '';
53 if(length($auth_cookie) >= 16){&pixel_noop; return;}
54
55 #Cheap UA-based bot filter
56 my $ua = $ENV{HTTP_USER_AGENT} || '';
57 if($ua =~ /bot|crawl|spider|slurp|wget|curl|headless|preview|monitor/i){&pixel_noop; return;}
58
59 #Read or mint the session token
60 my $token = $query->cookie('tf_a') || '';
61 $token =~ s/[^a-f0-9]//g;
62 my $is_new = 0;
63 if(length($token) != 40){
64 my @hex = ('0'..'9','a'..'f');
65 $token = '';
66 $token .= $hex[int(rand(@hex))] for 1..40;
67 $is_new = 1;
68 }
69
70 #Inputs
71 my $path = $query->param('p') || $ENV{HTTP_REFERER} || '/';
72 $path =~ s{^https?://[^/]+}{}; #Strip host if a full URL was sent
73 $path = substr($path, 0, 500);
74 $path =~ s/[\x00-\x1f]//g;
75
76 my $ref_full = $query->param('r') || $ENV{HTTP_REFERER} || '';
77 my $ref_host = '';
78 $ref_host = lc($1) if $ref_full =~ m{^https?://([^/]+)};
79 $ref_host = substr($ref_host, 0, 191);
80
81 my $utm_source = substr(($query->param('us') || ''), 0, 120);
82 my $utm_medium = substr(($query->param('um') || ''), 0, 120);
83 my $utm_campaign = substr(($query->param('uc') || ''), 0, 120);
84
85 my $ua_hash = sha1_hex($ua);
86 my $ip = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR} || '';
87 $ip =~ s/,.*$//; $ip =~ s/\s+//g;
88 my $ip_hash = sha1_hex($ip);
89
90 my $token_q = $token;
91 my $path_q = &q($path);
92 my $ref_q = &q($ref_host);
93 my $us_q = &q($utm_source);
94 my $um_q = &q($utm_medium);
95 my $uc_q = &q($utm_campaign);
96 my $ua_q = &q($ua_hash);
97 my $ip_q = &q($ip_hash);
98
99 my $dbh = $db->db_connect();
100 if(!$dbh){&pixel_noop($is_new ? $token : ''); return;}
101
102 # --- phase5-tracking-exclusion :: 2026-07-02 ---
103 {
104 my $ip_check = $ip;
105 $ip_check =~ s/[^0-9a-fA-F:.]//g;
106 if(length $ip_check){
107 my $excl = $db->db_readwrite($dbh, qq~
108 SELECT id FROM `${database_name}`.tracking_exclusions
109 WHERE active=1 AND ip='$ip_check' LIMIT 1
110 ~, $ENV{SCRIPT_NAME}, __LINE__);
111 if($excl && $excl->{id}){
112 $db->db_disconnect($dbh);
113 &send_pixel($is_new ? $token : '');
114 return;
115 }
116 }
117 }
118
119 #Upsert the session row
120 my $existing = $db->db_readwrite($dbh, qq~SELECT id, page_count FROM `${database_name}`.anon_sessions WHERE session_token='$token_q' LIMIT 1~, $ENV{SCRIPT_NAME}, __LINE__);
121
122 my ($sid, $seq);
123 if($existing && $existing->{id}){
124 $sid = $existing->{id} + 0;
125 $seq = ($existing->{page_count} || 0) + 0;
126 $db->db_readwrite($dbh, qq~UPDATE `${database_name}`.anon_sessions SET last_seen_at=NOW(), page_count=page_count+1 WHERE id='$sid'~, $ENV{SCRIPT_NAME}, __LINE__);
127 }else{
128 my $r = $db->db_readwrite($dbh, qq~INSERT INTO `${database_name}`.anon_sessions (session_token, first_seen_at, last_seen_at, end_reason, referer_host, utm_source, utm_medium, utm_campaign, landing_path, user_agent_hash, ip_hash, page_count) VALUES ('$token_q', NOW(), NOW(), 'active', '$ref_q', '$us_q', '$um_q', '$uc_q', '$path_q', '$ua_q', '$ip_q', 1)~, $ENV{SCRIPT_NAME}, __LINE__);
129 $sid = $r ? ($r->{mysql_insertid} || 0) + 0 : 0;
130 $seq = 0;
131 }
132
133 #Append the pageview row
134 if($sid){
135 $db->db_readwrite($dbh, qq~INSERT INTO `${database_name}`.anon_pageviews (session_id, sequence, page_path, occurred_at) VALUES ('$sid', '$seq', '$path_q', NOW())~, $ENV{SCRIPT_NAME}, __LINE__);
136 }
137
138 $db->db_disconnect($dbh);
139
140 &send_pixel($is_new ? $token : '');
141}
142
143sub send_pixel{
144 my($new_token) = @_;
145 print qq~Status: 200 OK\nContent-Type: image/gif\n~;
146 if($new_token){
147 #365-day session; SameSite=Lax + HttpOnly so XSS can't read it
148 print qq~Set-Cookie: tf_a=$new_token; Path=/; Max-Age=31536000; SameSite=Lax; HttpOnly\n~;
149 }
150 print qq~Cache-Control: no-store, no-cache, must-revalidate, max-age=0\nPragma: no-cache\n\n~;
151 print pack('H*', $PIXEL_HEX);
152}
153
154sub pixel_noop{
155 my($new_token) = @_;
156 print qq~Status: 200 OK\nContent-Type: image/gif\nCache-Control: no-store\n\n~;
157 print pack('H*', $PIXEL_HEX);
158}
159
160#SQL-escape any free-text input - we already pre-sanitized lengths upstream
161sub q{
162 my $s = shift // '';
163 $s =~ s/\\/\\\\/g;
164 $s =~ s/'/''/g;
165 return $s;
166}
Keyboard: j next diff k previous diff g top G bottom r restore c compile-check ? help