#!/usr/bin/perl
#
# Per-request view of what the long pool actually ran, built from Apache's
# access log. FPM cannot provide this: the long pool is reached through
# ProxyPassMatch, which rewrites the URI to /index.php before FPM sees it, so
# pm.status_path?full reports "/index.php" for every long-pool worker.
#
# Reports true concurrency by reconstructing each request's interval as
# [timestamp, timestamp + duration]. Apache's %t is the time the request was
# RECEIVED, not written, so the logged timestamp is the START of the interval --
# this script had it backwards until 2026-08-17 and every concurrency figure it
# produced before then was wrong. See 000-default.conf's LogFormat:
#   %{%y-%m-%d %H:%M:%S}t %{X-Forwarded-For}i %{pid}P %V "%r" %{ms}T %B %>s "%{UA}i"
# The error inflated peaks: reconstructing a fan-out backwards from its log times
# overlaps requests that in reality ran one after another. It put the 2026-08-14
# burst at 143 simultaneous advancedSearch requests, where FPM's own counters
# capped at 80 busy workers with max_listen_q = 0 all day, and the app-side log
# showed 85 concurrent jobs. Concurrency is what sizes pm.max_children; request
# count does not.
#
# Usage:
#   sudo ./pool-traffic-report.pl /var/log/apache2/access.log
#   sudo zcat /var/log/apache2/access.log.*.gz | ./pool-traffic-report.pl
#   sudo ./pool-traffic-report.pl --all --since '26-08-14 14:00' access.log
#
# Options:
#   --all              every request, not just long-pool routes
#   --json             machine-readable output for the portal monitoring UI
#   --since 'YY-MM-DD HH:MM:SS'
#   --until 'YY-MM-DD HH:MM:SS'
#
# Client IP addresses are deliberately NOT collected, in either family. They were
# reported here as "top consumers by client ip" until 2026-08-20 and dropped because
# this output is persisted to disk nightly, which made it personal data at rest for
# no operational gain: attributing load to a customer is done from the tool logs'
# Subdomain column, which is how one account was identified as 24,765 of 24,920
# worker-seconds during the 2026-08-17 investigation. The access log cannot answer
# that question anyway -- every request arrives from the ALB.
#
use strict;
use warnings;
use Time::Local qw(timelocal timegm);

my ($all, $json, $since, $until) = (0, 0, undef, undef);
my @files;
while (defined(my $a = shift @ARGV)) {
	if    ($a eq '--all')   { $all = 1 }
	elsif ($a eq '--json')  { $json = 1 }
	elsif ($a eq '--since') { $since = shift @ARGV }
	elsif ($a eq '--until') { $until = shift @ARGV }
	elsif ($a =~ /^-/)      { die "unknown option: $a\n" }
	else                    { push @files, $a }
}

# Mirrors conf-available/businessmap-sa-long.conf and
# conf-available/businessmap-sa-reporting.conf. The trailing (/|$) means each
# alternative must end on a whole path segment -- a bare "external/dw" matches
# nothing, which is why every DW ingest silently ran in the fast pool until
# 2026-08-14. Keep both in step with the Apache files.
#
# reportingProxy moved to its own pool on 2026-08-17, so it is matched separately
# rather than folded in here: concurrency is per-pool, and reporting it as one
# number would size neither pm.max_children correctly.
my $LONG = qr{^/(?:healthIndexes
	|internal/premiumHealthIndexes
	|reportingApi/v1/(?:playgroundReportingProxy|premiumHealthIndexes|userAssignment|proxyDataWarehouse)
	|userAssignmentReportBB
	|hubspotIntegration
	|proxyDataWarehouse(?!/dashboard)
	|boardAllocationReport
	|boardAssignmentReport
	|generateExecutiveReportRD
	|external/dw\w*
	|dw/v1
	)(?:/|$)}x;
my $REPORTING = qr{^/reportingApi/v1/reportingProxy(?:/|$)};

# Tools that are BOTH in a pool regex above AND redirected to the portal by
# conf-available/businessmap-sa-portal-redirects.conf. Apache answers these itself, before
# any pool is involved, so they occupy no FPM worker. Counting them against [long] would
# mis-size the one pool that is actually tight -- pm.max_children = 12 -- with requests
# that never ran PHP. Same reasoning as is_static() below, different door.
#
# Only the INTERSECTION belongs here. A portal-redirected tool that matches neither regex
# above already falls to the 'www' bucket, where a 0 ms redirect changes nothing. When a
# tool is added to businessmap-sa-portal-redirects.conf, add it here only if it also
# appears in $LONG or $REPORTING. That makes three files to keep in step; the redirect
# config's header lists all three pool files for exactly this reason.
#
# /hubspotIntegration/callback is excluded because it is NOT redirected: PHP serves it
# from [long] for the OAuth deprecation window and emits its own 302, which must keep
# counting. Case-sensitive like $LONG -- a miscased path never matched that regex either.
my $PORTAL_REDIRECT = qr{^/(?:healthIndexes
	|hubspotIntegration(?!/callback)
	|boardAllocationReport
	|boardAssignmentReport
	)(?:/|$)}x;

# Requests Apache serves from disk, which never reach PHP and occupy no FPM worker.
# They must be kept out of pool concurrency or they dominate it: on 2026-08-19 the
# non-pool bucket peaked at 51 simultaneous, of which 50 were 1,521 static requests
# holding 2.9 SECONDS between them -- one browser opening a page and firing fifty
# asset requests in the same instant. Excluding them left a peak of 7, which is
# exactly what FPM's own sampled max_active reported for [www] that day. Two
# independent measurements agreeing is why this split is here rather than a guess.
#
# Deliberately no .json or .php: an API route can end in either.
sub is_static {
	my $p = shift;
	return 1 if $p =~ m{^/resources/};
	return 1 if $p =~ m{\.(?:css|js|mjs|png|jpe?g|gif|svg|ico|woff2?|ttf|eot|map|webp|avif)$};
	return 0;
}

# Every static hit collapses to this one synthetic route. Left un-collapsed they add
# hundreds of rows carrying milliseconds each, which buries the routes that matter.
my $STATIC_ROUTE = '/<static-assets>';

# Likewise for portal redirects Apache served without touching PHP.
my $REDIRECT_ROUTE = '/<portal-redirects>';

sub to_epoch {
	my ($y, $mo, $d, $h, $mi, $s) = @_;
	return timelocal($s, $mi, $h, $d, $mo - 1, 2000 + $y);
}

sub parse_bound {
	my $t = shift or return undef;
	$t =~ /^(\d\d)-(\d\d)-(\d\d)[ T](\d\d):(\d\d)(?::(\d\d))?$/
		or die "bad time '$t', want YY-MM-DD HH:MM[:SS]\n";
	return to_epoch($1, $2, $3, $4, $5, $6 // 0);
}
$since = parse_bound($since);
$until = parse_bound($until);

my (%stat, %events, %hour_n, %ua_secs, %pool_n);
my %static   = (n => 0, secs => 0);
my %redirect = (n => 0, secs => 0);
my ($parsed, $skipped, $tmin, $tmax) = (0, 0, undef, undef);

@ARGV = @files;
while (my $line = <>) {
	# Position-independent on purpose. Field 9 is %{ms}T and field 11 is %>s;
	# parsing this log positionally once produced a completely fabricated error
	# profile. X-Forwarded-For also arrives as "ip1, ip2" from the ALB, which
	# shifts every later column.
	unless ($line =~ m{
		^(\d\d)-(\d\d)-(\d\d)\ (\d\d):(\d\d):(\d\d)\    # 1-6  date, time
		(\S+?),?\                                       # 7    first XFF hop
		.*?"(\S+)\ (\S+)\ HTTP[^"]*"\                   # 8-9  method, url
		(\d+)\ (\S+)\ (\d{3})                           # 10-12 ms, bytes, status
		(?:\ "([^"]*)")?                                # 13   user agent
	}x) {
		$skipped++;
		next;
	}
	# Copy every capture out now. The split and substitution below reset $1..$n,
	# so anything still read from them later silently becomes undef.
	my ($yy, $mm, $dd, $hh) = ($1, $2, $3, $4);
	# $7 is the first X-Forwarded-For hop. Captured so the numbering below stays
	# aligned with the regex, deliberately not stored -- see the header.
	my ($method, $url, $ms, $status, $ua) = ($8, $9, $10, $12, $13 // '-');

	# %t is the receipt time, so this is the START of the request. --since/--until
	# filter on it, which is what "requests that arrived in this window" means; a
	# request that arrives inside the window still contributes its whole duration.
	my $start = to_epoch($yy, $mm, $dd, $hh, $5, $6);
	next if defined $since && $start < $since;
	next if defined $until && $start > $until;

	# Apache matches on the path, so the query string must come off before the
	# (/|$) anchor is tested -- "/dw/v1?x=1" ends in "?" and would not match.
	(my $path = $url) =~ s/\?.*//;
	# Apache 302s these before the proxy handler is reached, so they belong to no pool.
	my $is_redirect = $status == 302 && $method =~ /^(?:GET|HEAD)$/ && $path =~ $PORTAL_REDIRECT;
	my $pool = $is_redirect ? undef
		: ($path =~ $REPORTING ? 'reporting' : ($path =~ $LONG ? 'long' : undef));
	next unless $all || $pool;

	$parsed++;

	# Floor at 1 ms so a request opens before it closes. sweep() sorts closing events
	# before opening ones at an identical timestamp, which is right for two DISTINCT
	# requests but wrong for one whose start and end coincide: its own close is
	# processed first, so it never counts as present and can drive the running total
	# negative, hiding requests that really were concurrent. Measured before this
	# floor: four requests in flight at one instant, one of them 0 ms, reported a peak
	# of 3 and gave the 0 ms request peak=0. Mostly bites --all, where fast www
	# routes can log 0 ms; long and reporting requests are seconds long. Costs at
	# most 1 ms per request in the worker-seconds totals.
	my $secs = $ms / 1000;
	$secs = 0.001 if $secs < 0.001;

	my $end   = $start + $secs;
	$tmin = $start if !defined $tmin || $start < $tmin;
	$tmax = $end   if !defined $tmax || $end   > $tmax;

	# Keep leading segments that look like route names and drop the rest, so a
	# base64 report token or a numeric id does not become its own route. Four
	# segments deep because the hot path is reportingApi/v1/reportingProxy/
	# advancedSearch and collapsing to two would merge every reportingApi route.
	my $is_static = !$pool && !$is_redirect && is_static($path);

	my $route;
	if ($is_static) {
		$route = $STATIC_ROUTE;
		$static{n}++;
		$static{secs} += $secs;
	} elsif ($is_redirect) {
		$route = $REDIRECT_ROUTE;
		$redirect{n}++;
		$redirect{secs} += $secs;
	} else {
		my @seg = grep { length } split m{/}, $path;
		my @keep;
		for my $s (@seg) {
			last if @keep >= 4;
			last unless $s =~ /^[A-Za-z][A-Za-z0-9_.-]*$/ && length($s) <= 30;
			push @keep, $s;
		}
		$route = '/' . join('/', @keep);
	}

	my $r = $stat{$route} ||= { n => 0, secs => [], sum => 0, cls => {} };
	$r->{n}++;
	$r->{sum} += $secs;
	push @{ $r->{secs} }, $secs;
	$r->{cls}{ substr($status, 0, 1) . 'xx' }++;
	push @{ $r->{err} }, "$status $method $path" if $status >= 500;

	push @{ $events{$route} }, [$start, 1], [$end, -1];

	# '*' and the pool buckets both mean "requests that reach PHP", so static hits go
	# to their own bucket and nowhere else. Per-pool because each pool has its own
	# pm.max_children to size; routes belonging to neither pool appear only under
	# --all and are attributed to 'www', which is where Apache sends them.
	if ($is_static) {
		push @{ $events{'static'} }, [$start, 1], [$end, -1];
	} elsif ($is_redirect) {
		push @{ $events{'redirect'} }, [$start, 1], [$end, -1];
	} else {
		push @{ $events{'*'} }, [$start, 1], [$end, -1];
		push @{ $events{'pool:' . ($pool // 'www')} }, [$start, 1], [$end, -1];
		$pool_n{ $pool // 'www' }++;
	}
	$hour_n{"$yy-$mm-$dd $hh"}++;
	$ua_secs{ substr($ua, 0, 46) } += $secs;
}

unless ($parsed) {
	# An empty result is a valid answer for a quiet window, but it is also what a
	# LogFormat change looks like -- so say how many lines failed to parse either way,
	# and let the caller decide. fpm-traffic-snapshot refuses to persist a JSON
	# document with parsed == 0 for exactly this reason.
	if ($json) {
		printf "{\n  \"schema\": 1,\n  \"parsed\": 0,\n  \"skipped\": %d,\n  \"scope\": \"%s\",\n"
			. "  \"tz\": \"%s\",\n  \"utc_offset_seconds\": %d,\n"
			. "  \"window\": null,\n  \"pools\": {},\n  \"combined_peak\": 0,\n"
			. "  \"routes\": [],\n  \"hours\": [],\n  \"top_user_agents\": [],\n  \"errors_5xx\": []\n}\n",
			$skipped, ($all ? 'all' : 'pool-routed'), tzname(), utc_offset(time);
	} else {
		print "No matching requests (skipped $skipped unparseable lines).\n";
	}
	exit 0;
}

sub pct {
	my ($aref, $p) = @_;
	my @s = sort { $a <=> $b } @$aref;
	my $i = int($p * $#s + 0.5);
	$i = $#s if $i > $#s;
	return $s[$i];
}

# Sweep line: +1 at each start, -1 at each end. Closing events sort before
# opening ones at an identical timestamp, so a request ending exactly as another
# begins is not counted as overlapping. That tie-break is only safe because
# durations are floored at 1 ms above -- see the comment there.
sub sweep {
	my $ev = shift;
	my @e = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @$ev;
	my ($cur, $max, $prev) = (0, 0, undef);
	my %at;
	for my $x (@e) {
		$at{$cur} += $x->[0] - $prev if defined $prev && $cur > 0;
		$cur += $x->[1];
		$max = $cur if $cur > $max;
		$prev = $x->[0];
	}
	return ($max, \%at);
}

# The log carries local wall-clock time and timelocal() reads it as such, so the
# epochs below are correct under any zone. The offset is reported so a consumer can
# tell whether it is comparing like with like: the FPM sampler writes UTC, and this
# box is Etc/UTC, so today they agree -- a future zone change would silently shift
# every traffic figure against every pool figure without this field.
sub utc_offset { my $t = shift; return timegm(localtime($t)) - $t }
sub tzname     { return $ENV{TZ} // (utc_offset(time) == 0 ? 'UTC' : 'local') }
sub iso {
	my @g = gmtime(shift);
	return sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ',
		$g[5] + 1900, $g[4] + 1, $g[3], $g[2], $g[1], $g[0]);
}

sub jstr {
	my $v = shift;
	$v = '' unless defined $v;
	$v =~ s/\\/\\\\/g;
	$v =~ s/"/\\"/g;
	$v =~ s/([\x00-\x1f])/sprintf('\\u%04x', ord($1))/ge;
	return '"' . $v . '"';
}
sub jsec { return sprintf('%.3f', shift) + 0 }

# --- aggregates shared by both output modes ----------------------------------
my ($peak) = sweep($events{'*'});
my ($static_peak) = sweep($events{'static'} // []);
my ($redirect_peak) = sweep($events{'redirect'} // []);
my $span = ($tmax - $tmin) || 0.001;

# Rungs are fixed rather than derived from pm.max_children, because this script reads
# the access log and never sees a pool's config. The caps as of 2026-08-20 are 12
# (long), 40 (reporting) and 40 (www dynamic); keep 12 and 40 in the list.
my @LADDER = (5, 10, 12, 20, 30, 40, 48, 60, 80);

my %pool_res;
for my $pool (sort keys %pool_n) {
	my ($ppeak, $pat) = sweep($events{"pool:$pool"});
	my @rungs;
	for my $n (@LADDER) {
		next if $n > $ppeak;
		my $s = 0;
		$s += $pat->{$_} // 0 for grep { $_ >= $n } keys %$pat;
		push @rungs, { n => $n, seconds => $s, pct => 100 * $s / $span };
	}
	$pool_res{$pool} = { requests => $pool_n{$pool}, peak => $ppeak, rungs => \@rungs };
}

my @routes = sort { $stat{$b}{sum} <=> $stat{$a}{sum} } keys %stat;
my %route_peak = map { $_ => (sweep($events{$_}))[0] } @routes;
my @hot     = grep { defined } (sort { $hour_n{$b} <=> $hour_n{$a} } keys %hour_n)[0 .. 7];
my @top_ua  = grep { defined } (sort { $ua_secs{$b} <=> $ua_secs{$a} } keys %ua_secs)[0 .. 4];
my %e;
$e{$_}++ for map { @{ $stat{$_}{err} // [] } } keys %stat;
my @top_err = grep { defined } (sort { $e{$b} <=> $e{$a} } keys %e)[0 .. 14];

# --- JSON --------------------------------------------------------------------
if ($json) {
	print "{\n";
	print '  "schema": 1,', "\n";
	printf "  \"scope\": %s,\n", jstr($all ? 'all' : 'pool-routed');
	printf "  \"tz\": %s,\n", jstr(tzname());
	printf "  \"utc_offset_seconds\": %d,\n", utc_offset($tmin);
	printf "  \"parsed\": %d,\n  \"skipped\": %d,\n", $parsed, $skipped;

	# Requested vs actual, because --until filters on request START: a request that
	# arrives at 23:59:58 and runs 200s is counted in full, so the data legitimately
	# extends past the requested end. A consumer computing "%% of window" needs the
	# actual extent, which is what every pct below divides by.
	printf "  \"requested\": { \"since\": %s, \"until\": %s },\n",
		(defined $since ? jstr(iso($since)) : 'null'),
		(defined $until ? jstr(iso($until)) : 'null');
	printf "  \"window\": { \"start\": %d, \"end\": %d, \"start_iso\": %s, \"end_iso\": %s, \"hours\": %s },\n",
		$tmin, $tmax, jstr(iso($tmin)), jstr(iso($tmax)), jsec($span / 3600);

	my @pj;
	for my $pool (sort keys %pool_res) {
		my $r = $pool_res{$pool};
		my @rj = map { sprintf('{"n":%d,"seconds":%s,"pct":%s}', $_->{n}, jsec($_->{seconds}), jsec($_->{pct})) }
			@{ $r->{rungs} };
		push @pj, sprintf('    %s: {"requests":%d,"peak":%d,"ladder":[%s]}',
			jstr($pool), $r->{requests}, $r->{peak}, join(',', @rj));
	}
	printf "  \"pools\": {\n%s\n  },\n", join(",\n", @pj);
	printf "  \"combined_peak\": %d,\n", $peak;

	# Reported so the browser fan-out is visible, and separate so nobody sizes a pool
	# from it. A high peak here next to near-zero seconds is a page load, not load.
	printf "  \"static\": { \"requests\": %d, \"seconds\": %s, \"peak\": %d },\n",
		$static{n}, jsec($static{secs}), $static_peak;

	# Separate from every pool: Apache served these, no worker was held.
	printf "  \"portal_redirects\": { \"requests\": %d, \"seconds\": %s, \"peak\": %d },\n",
		$redirect{n}, jsec($redirect{secs}), $redirect_peak;

	my @rj;
	for my $route (@routes) {
		my $r = $stat{$route};
		my @cls = map { sprintf('%s:%d', jstr($_), $r->{cls}{$_}) } sort keys %{ $r->{cls} };
		push @rj, sprintf(
			'    {"route":%s,"n":%d,"seconds_total":%s,"p50":%s,"p95":%s,"p99":%s,"max":%s,"peak":%d,"status":{%s}}',
			jstr($route), $r->{n}, jsec($r->{sum}),
			jsec(pct($r->{secs}, 0.50)), jsec(pct($r->{secs}, 0.95)),
			jsec(pct($r->{secs}, 0.99)), jsec(pct($r->{secs}, 1.00)),
			$route_peak{$route}, join(',', @cls));
	}
	printf "  \"routes\": [\n%s\n  ],\n", join(",\n", @rj);

	# Emit the hour as UTC ISO as well as the log's own YY-MM-DD HH key. Everything
	# else in this document is UTC, and leaving one field in local wall-clock is how a
	# consumer ends up plotting traffic an hour away from the pool metrics it overlays.
	printf "  \"hours\": [%s],\n",
		join(',', map {
			my ($y, $mo, $d, $h) = /^(\d\d)-(\d\d)-(\d\d) (\d\d)$/
				? ($1, $2, $3, $4) : ();
			sprintf('{"hour":%s,"hour_start_iso":%s,"requests":%d}',
				jstr($_),
				(defined $y ? jstr(iso(to_epoch($y, $mo, $d, $h, 0, 0))) : 'null'),
				$hour_n{$_});
		} sort { $hour_n{$b} <=> $hour_n{$a} } @hot);
	printf "  \"top_user_agents\": [%s],\n",
		join(',', map { sprintf('{"ua":%s,"seconds":%s}', jstr($_), jsec($ua_secs{$_})) } @top_ua);
	printf "  \"errors_5xx\": [%s]\n",
		join(',', map { sprintf('{"count":%d,"request":%s}', $e{$_}, jstr($_)) } @top_err);
	print "}\n";
	exit 0;
}

# --- text --------------------------------------------------------------------
printf "Window   : %s -> %s (%.1f h)\n",
	scalar(localtime($tmin)), scalar(localtime($tmax)), $span / 3600;
printf "Requests : %d %s (%d lines unparsed)\n",
	$parsed, ($all ? 'total' : 'pool-routed'), $skipped;
printf "           %s\n\n", join('  ', map { "$_=$pool_n{$_}" } sort keys %pool_n);

print "CONCURRENCY  (this is what sizes pm.max_children -- PER POOL, since each\n";
print "has its own limit; the combined figure sizes nothing)\n";
for my $pool (sort keys %pool_res) {
	my $r = $pool_res{$pool};
	printf "\n  [%s]  peak: %d simultaneous\n", $pool, $r->{peak};
	for my $g (@{ $r->{rungs} }) {
		printf "    >= %-3d for %8.1f s  (%.3f%% of window)\n", $g->{n}, $g->{seconds}, $g->{pct};
	}
}
printf "\n  all PHP-bound routes combined, peak: %d\n", $peak;
printf "  static assets (never reach PHP): %d requests, %.1f s held, peak %d\n",
	$static{n}, $static{secs}, $static_peak if $static{n};
printf "  portal redirects (302 by Apache, never reach PHP): %d requests, peak %d\n",
	$redirect{n}, $redirect_peak if $redirect{n};

printf "\n%-52s %7s %7s %7s %7s %7s  %s\n",
	'ROUTE', 'N', 'p50', 'p95', 'p99', 'max', 'STATUS';
for my $route (@routes) {
	my $r = $stat{$route};
	printf "%-52s %7d %6.1fs %6.1fs %6.1fs %6.1fs  %s  peak=%d\n",
		substr($route, 0, 52), $r->{n},
		pct($r->{secs}, 0.50), pct($r->{secs}, 0.95),
		pct($r->{secs}, 0.99), pct($r->{secs}, 1.00),
		join(' ', map { "$_=$r->{cls}{$_}" } sort keys %{ $r->{cls} }),
		$route_peak{$route};
}

print "\nBUSIEST HOURS (requests)\n";
printf "  %s:00  %6d\n", $_, $hour_n{$_} for sort { $hour_n{$b} <=> $hour_n{$a} } @hot;

print "\nTOP CONSUMERS (worker-seconds held -- what actually occupies the pool)\n";
print "  by user agent\n";
printf "    %-46s %10.1f s\n", $_, $ua_secs{$_} for @top_ua;

if (@top_err) {
	print "\n5xx\n";
	printf "  %5d  %s\n", $e{$_}, $_ for @top_err;
}