diff options
Diffstat (limited to 'lib/Devel/Mwrap/Rproxy.pm')
| -rw-r--r-- | lib/Devel/Mwrap/Rproxy.pm | 220 |
1 files changed, 0 insertions, 220 deletions
diff --git a/lib/Devel/Mwrap/Rproxy.pm b/lib/Devel/Mwrap/Rproxy.pm deleted file mode 100644 index d5a9d9d..0000000 --- a/lib/Devel/Mwrap/Rproxy.pm +++ /dev/null @@ -1,220 +0,0 @@ -# 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; |