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.

1 files changed, 80 insertions, 1 deletions

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;