From 6395a6ba02fdad89dc0a606a9ce3e01d3baf3238 Mon Sep 17 00:00:00 2001
From: Eric Wong <e@80x24.org>
Date: Tue, 27 Dec 2022 14:17:12 +0000
Subject: rproxy: support GNU addr2line via pipe

We can filter the HTML and CSV and run it through addr2line to
decode addresses from rproxy.  We can't safely run another
process inside the embedded mwrap-httpd since that could
break `waitpid(-1, ...)' in the code we're being injected into.
---
 lib/Devel/Mwrap/Rproxy.pm | 81 ++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 80 insertions(+), 1 deletion(-)

diff --git a/lib/Devel/Mwrap/Rproxy.pm b/lib/Devel/Mwrap/Rproxy.pm
index 6db72e6..2b9ccc7 100644
--- a/lib/Devel/Mwrap/Rproxy.pm
+++ b/lib/Devel/Mwrap/Rproxy.pm
@@ -58,6 +58,17 @@ sub list {
 	r(200, $str);
 }
 
+our %addr2line; # { exe|lib => Devel::Mwrap::Rproxy::A2L }
+
+# addr2line bidirectional pipe wrapper
+sub a2l {
+	my ($exe, $addr) = @_;
+	my $a2l = $addr2line{$exe} //= Devel::Mwrap::Rproxy::A2L->new($exe);
+	chomp(my $line = $a2l->lookup($addr));
+	$line = Plack::Util::encode_html($line);
+	$line =~ /\A\?\?:/ ? "$line $exe $addr" : $line;
+}
+
 sub call { # PSGI entry point
 	my ($self, $env) = @_;
 	my $uri = $env->{REQUEST_URI};
@@ -76,9 +87,77 @@ sub call { # PSGI entry point
 	# this only expects httpd.h output, so no continuation lines:
 	$h = do { local $/ = "\r\n\r\n"; <$c> } // return r(500, "read: $!");
 	my ($code, @hdr) = split(/\r\n/, $h);
+	@hdr = grep(!/^Content-Length:/i, @hdr); # addr2line changes length
+	my $csv = grep(m!^Content-Type: text/csv!i, @hdr);
 	(undef, $code, undef) = split(/ /, $code);
 	@hdr = map { split(/: /, $_, 2) } @hdr;
-	[ $code, \@hdr, $c ];
+	sub {
+		my ($wcb) = @_;
+		my $http_out = $wcb->([$code, \@hdr]);
+		eval {
+			local %addr2line;
+			# extract executable|library(address)
+			if ($csv) {
+				while (<$c>) {
+					s/\\n/\0\0/g;
+					s!(["\0])
+						(/[^\("\0]+) # exe
+						\(([^\)"\0]+)\) # addr
+						(["\0])!
+						$1.a2l($2,$3).$4!gex;
+					s/\0\0/\\n/g;
+					$http_out->write($_);
+				}
+			} else {
+				while (<$c>) {
+					s!>
+						(/[^\(<]+) # exe
+						\(([^\)<]+)\) # addr
+						<!
+						'>'.a2l($1,$2).'<'!gex;
+					$http_out->write($_);
+				}
+			}
+			close $c;
+		};
+		warn "E: $@" if $@;
+		$http_out->close;
+	}
+}
+
+# requires GNU addr2line for stdin/stdout support
+package Devel::Mwrap::Rproxy::A2L;
+use v5.12;
+
+sub new {
+	my ($cls, $exe) = @_;
+	pipe(my ($rd, $_wr)) or die "pipe: $!";
+	pipe(my ($_rd, $wr)) or die "pipe: $!";
+	my $addr2line = $ENV{ADDR2LINE} // 'addr2line';
+	my $pid = fork // die "fork: $!";
+	if ($pid == 0) {
+		close $rd;
+		close $wr;
+		open STDIN, '<&', $_rd or die "STDIN: $!";
+		open STDOUT, '>&', $_wr or die "STDOUT: $!";
+		exec $addr2line, '-e', $exe;
+		die "exec $addr2line -e $exe: $!";
+	}
+	$_rd = $_wr = undef;
+	$wr->autoflush(1);
+	bless { rd => $rd, wr => $wr, pid => $pid }, __PACKAGE__;
+}
+
+sub lookup {
+	my ($self, $addr) = @_;
+	say { $self->{wr} } $addr;
+	readline($self->{rd});
+}
+
+sub DESTROY {
+	my ($self) = @_;
+	delete @$self{qw(rd wr)};
+	waitpid(delete $self->{pid}, 0);
 }
 
 1;
-- 
cgit v1.2.3-24-ge0c7