Diff

/var/www/vhosts/3dshawn.com/site1/MODS/Webhook.pm

added on local at 2026-07-11 19:37:59

Added

+131

lines

Removed

-0

lines

Context

unchanged

Blobs

from
to 28bc6ad89966

Restore this content →

Unified diff

Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.

	1	package MODS::Webhook;
	2	#======================================================================
	3	# DriftSense -- MODS::Webhook
	4	#
	5	# Self-contained HTTP(S) client. Uses core Perl + a shelled-out `curl`
	6	# so we don't drag in LWP::Protocol::https / IO::Socket::SSL as CPAN
	7	# installs. `curl` ships on every mainstream Linux distro.
	8	#
	9	# Public API:
	10	#
	11	# my ($code, $body, $err) = MODS::Webhook::post_json($url, $ref_or_str, %opts);
	12	#
	13	# $url : http:// or https:// (schemes are validated)
	14	# $ref_or_str : hashref/arrayref (encoded to JSON) OR a raw string
	15	# %opts:
	16	# timeout : seconds, default 10
	17	# user_agent : string, default "DriftSense/1.0 (webhook)"
	18	# insecure : truthy => skip TLS cert verify (default off)
	19	#
	20	# Returns:
	21	# ($code, $body, $err)
	22	# $code : integer HTTP status (0 if the transport itself failed)
	23	# $body : response body, up to 8 KB
	24	# $err : undef on success, else short error string
	25	#
	26	# Security:
	27	# - Only http and https URLs are accepted.
	28	# - We use `system(@argv)` (list form) so no shell metacharacters are
	29	# interpreted from the URL or the JSON body.
	30	# - Body is passed on stdin, not as an argv arg, so its size + content
	31	# never touch a command-line buffer.
	32	#======================================================================
	33	use strict;
	34	use warnings;
	35	use IPC::Open3;
	36	use Symbol 'gensym';
	37	use JSON::PP ();
	38	use POSIX ':sys_wait_h';
	39
	40	my $CURL_BIN = '/usr/bin/curl'; # yum / apt / brew all put it here
	41	my $DEFAULT_TIMEOUT = 10;
	42	my $MAX_RESPONSE_BYTES = 8 * 1024;
	43
	44	sub post_json {
	45	my ($url, $payload, %opts) = @_;
	46
	47	return (0, '', 'no URL') unless defined $url && length $url;
	48	return (0, '', 'bad URL') unless $url =~ m!^https?://[^\s]+$!i;
	49	return (0, '', "no curl at $CURL_BIN") unless -x $CURL_BIN;
	50
	51	my $timeout = $opts{timeout} \|\| $DEFAULT_TIMEOUT;
	52	my $user_agent = $opts{user_agent} \|\| 'DriftSense/1.0 (webhook)';
	53
	54	my $body;
	55	if (ref($payload) eq 'HASH' \|\| ref($payload) eq 'ARRAY') {
	56	$body = eval { JSON::PP::encode_json($payload) };
	57	return (0, '', "encode_json: $@") if $@;
	58	} else {
	59	$body = defined($payload) ? "$payload" : '';
	60	}
	61
	62	# Argv: no shell interpolation, safe against injection via URL/body.
	63	my @argv = (
	64	$CURL_BIN,
	65	'--silent', '--show-error',
	66	'--max-time', $timeout,
	67	'--user-agent', $user_agent,
	68	'--request', 'POST',
	69	'--header', 'Content-Type: application/json',
	70	'--data-binary', '@-', # read body from stdin
	71	'--write-out', "\n__CURL_HTTP_CODE__:%{http_code}\n",
	72	);
	73	push @argv, '--insecure' if $opts{insecure};
	74	push @argv, $url;
	75
	76	my ($wtr, $rdr, $err_fh);
	77	$err_fh = gensym;
	78	my $pid = eval { open3($wtr, $rdr, $err_fh, @argv) };
	79	return (0, '', "open3: $@") if $@ \|\| !$pid;
	80
	81	# Write body, close stdin so curl can send + return.
	82	binmode $wtr;
	83	print {$wtr} $body if length $body;
	84	close $wtr;
	85
	86	# Read up to MAX_RESPONSE_BYTES from stdout + all of stderr (short).
	87	my $out = _slurp_capped($rdr, $MAX_RESPONSE_BYTES);
	88	my $errbuf = do { local $/; <$err_fh> // '' };
	89	close $rdr;
	90	close $err_fh;
	91	waitpid $pid, 0;
	92	my $exit = $? >> 8;
	93
	94	# Extract HTTP code from our --write-out marker; strip the marker
	95	# from the returned body.
	96	my $code = 0;
	97	if ($out =~ s/\n?__CURL_HTTP_CODE__:(\d+)\n?$//) {
	98	$code = int($1);
	99	}
	100
	101	if ($exit != 0 && $code == 0) {
	102	# curl failed before it could report a code (connection refused,
	103	# DNS, TLS handshake). Surface curl's stderr as the error.
	104	my $msg = $errbuf;
	105	$msg =~ s/\s+/ /g; $msg =~ s/^\s+\|\s+$//g;
	106	$msg \|\|= "curl exit $exit";
	107	return (0, $out, $msg);
	108	}
	109
	110	if ($code >= 200 && $code < 400) {
	111	return ($code, $out, undef);
	112	}
	113	my $msg = "HTTP $code";
	114	return ($code, $out, $msg);
	115	}
	116
	117	sub _slurp_capped {
	118	my ($fh, $cap) = @_;
	119	my $buf = '';
	120	my $read_total = 0;
	121	while ($read_total < $cap) {
	122	my $chunk = '';
	123	my $n = sysread($fh, $chunk, $cap - $read_total);
	124	last unless $n;
	125	$buf .= $chunk;
	126	$read_total += $n;
	127	}
	128	return $buf;
	129	}
	130
	131	1;