diff options
Diffstat (limited to 'lib/Devel/Mwrap/Rproxy.pm')
| -rw-r--r-- | lib/Devel/Mwrap/Rproxy.pm | 220 |
1 files changed, 220 insertions, 0 deletions
diff --git a/lib/Devel/Mwrap/Rproxy.pm b/lib/Devel/Mwrap/Rproxy.pm new file mode 100644 index 0000000..d5a9d9d --- /dev/null +++ b/lib/Devel/Mwrap/Rproxy.pm @@ -0,0 +1,220 @@ +# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> +# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> + +# minimal reverse proxy to expose the embedded httpd.h UNIX sockets +# via PSGI (and thus TCP HTTP/1.x). This does not have a hard dependency +# on Mwrap.so. +# +# Warning: this has a synchronous wait dependency, so isn't suited for +# non-blocking async HTTP servers. +package Devel::Mwrap::Rproxy; +use v5.12; # strict +use Fcntl qw(SEEK_SET); +use IO::Socket::UNIX; +use Plack::Util; + +sub new { bless { socket_dir => $_[1]}, $_[0] } + +sub r { + [ $_[0], [ + 'Expires' => 'Fri, 01 Jan 1980 00:00:00 GMT', + 'Pragma' => 'no-cache', + 'Cache-Control' => 'no-cache, max-age=0, must-revalidate', + 'Content-Type' => 'text/html; charset=UTF-8', + 'Content-Length' => length($_[1]), + ], [ $_[1] ] ]; +} + +my $valid_pid = $^O eq 'linux' ? sub { + my ($pid) = @_; + if (open(my $fh, '<', "/proc/$pid/cmdline")) { + local $/; + my $str = <$fh> // return; + $str =~ tr/\0/ /; + Plack::Util::encode_html($str); + } +} : sub { kill(0, $_[0]) ? "PID: $_[0]" : undef }; + +sub list { + my ($self, $env) = @_; + state $t = 'mwrap reverse proxy endpoints'; + open(my $fh, '+>', \(my $str)) or die "open: $!"; + print $fh '<html><head><title>', $t, '</title></head><body><pre>', $t, + "\n\n"; + my $dir = $self->{socket_dir}; + opendir(my $dh, $dir) or return r(500, "socket_dir: $!"); + my @socks = grep(/\A[0-9]+\.sock\z/, readdir($dh)); + my %o = (Type => SOCK_STREAM, Peer => undef); + for (@socks) { + $o{Peer} = "$dir/$_"; + substr($_, -5, 5, ''); # chop off .sock + my $cmd = $valid_pid->($_) // next; + my $c = IO::Socket::UNIX->new(%o) // next; + print $fh qq(<a\nhref="./$_/">$_</a>/); + $_ .= '/each/2000'; + say $fh qq(<a\nhref="./), $_, qq(">each/2000</a>\t), $cmd; + } + print $fh '</pre></body></html>'; + r(200, $str); +} + +our %addr2line; # { exe|lib => Devel::Mwrap::Rproxy::A2L } +my %cache; # "$exe\0$addr$st_ctime$st_size" => $line +my $cache_exp = 0; +my $cache_time = 1800; + +sub resolve_exe ($$) { + my ($exe, $st) = @_; + # n.b. this assumes PATH is identical across the rproxy and + # mwrap-httpd process, which may not always be the case: + if (index($exe, '/') < 0 && !-r $exe) { + for my $p (split(/:/, $ENV{PATH})) { + $p .= "/$exe"; + if (-x $p) { + $exe = $p; + last; + } + } + } + my $fh; + if (-T $exe && open($fh, '<', $exe)) { # is it text? use shebang + my $l = readline($fh); + $exe = ($l =~ /\A\#\![ \t]*(\S+)/) ? $1 : $^X; + } + return unless -e $exe; + my @st = stat(_); + + # Debian `perl-debug' is special: + if ($exe eq '/usr/bin/perl' && -x '/usr/bin/debugperl') { + @st = stat(_); + $exe = '/usr/bin/debugperl'; + } + $$st = pack('dd', $st[10], $st[7]); # ctime + size + $exe; +} + +# addr2line bidirectional pipe wrapper +sub a2l { + my ($exe, $addr) = @_; + $exe = resolve_exe($exe, \(my $st)) // return "$exe($addr)"; + $cache{"$addr\0$exe$st"} //= do { + my $a2l = $addr2line{$exe} //= + Devel::Mwrap::Rproxy::A2L->new($exe); + + $a2l ? do { + chomp(my $line = $a2l->lookup($addr)); + $line =~ s/\Q?? at ??:0\E//; # FreeBSD + $line = Plack::Util::encode_html($line); + $line =~ /\?\?/ ? "$line $exe($addr)" : + ($line =~ /\S/ ? $line : "$exe($addr)"); + } : "$exe($addr)" + } +} + +sub call { # PSGI entry point + my ($self, $env) = @_; + my $uri = $env->{REQUEST_URI}; + $uri =~ s!\A\Q$env->{SCRIPT_NAME}\E!!; + my $method = $env->{REQUEST_METHOD}; + return list(@_) if $uri eq '/' && $method eq 'GET'; + + # must have /$PID/ prefix to map socket + $uri =~ m!\A/([0-9]+)/! or return r(404, 'not found'); + my $s = "$self->{socket_dir}/$1.sock"; + my %o = (Peer => $s, Type => SOCK_STREAM); + my $c = IO::Socket::UNIX->new(%o) or return r(500, "connect: $!"); + my $h = "$method $uri HTTP/1.0\n\n"; + $s = send($c, $h, MSG_NOSIGNAL) // return r(500, "send: $!"); + $s == length($h) or return r(500, "send $s <".length($h)); + # 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; + sub { + my ($wcb) = @_; + my $http_out = $wcb->([$code, \@hdr]); + my $now = time; + if ($now > $cache_exp) { + undef %cache; + $cache_exp = $now + $cache_time; + } + + # GNU addr2line is slow with high bt:, and FreeBSD addr2line + # seems less capable. And we can't see addr2line in this + # anyways since we kill them at the end of this scope. + # So just disable MWRAP, here: + delete local $ENV{MWRAP}; + delete local $ENV{LD_PRELOAD}; + 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: $!"; + # -f/--functions needs -p/--pretty-print to go with it + my $addr2line = $ENV{ADDR2LINE} // 'addr2line -i -p -f'; + my @addr2line = split(/\s+/, $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) = @_; + $addr =~ s/\A\+//; + say { $self->{wr} } $addr; + readline($self->{rd}); +} + +sub DESTROY { + my ($self) = @_; + close($_) for (delete @$self{qw(wr rd)}); + waitpid(delete $self->{pid}, 0); +} + +1; |