1 files changed, 78 insertions, 0 deletions
diff --git a/lib/Devel/Mwrap/Rproxy.pm b/lib/Devel/Mwrap/Rproxy.pm
new file mode 100644
index 0000000..7955f55
--- /dev/null
+++ b/lib/Devel/Mwrap/Rproxy.pm
@@ -0,0 +1,78 @@
+# Copyright (C) mwrap hackers <mwrap-perl@80x24.org>
+# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt>
+
+# minimal reverse proxy to expose the embedded mwrap_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>;
+                $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";
+        opendir(my $dh, $self->{socket_dir}) or return r(500, "socket_dir: $!");
+        my @pids = grep(/\A[0-9]+\.sock\z/, readdir($dh));
+        for (@pids) {
+                substr($_, -5, 5, ''); # chop off .sock
+                my $cmd = $valid_pid->($_) // next;
+                $_ .= '/each/2000';
+                say $fh qq(<a\nhref="./), $_, '">', $_, "</a>\t", $cmd;
+        }
+        print $fh '</pre></body></html>';
+        r(200, $str);
+}
+
+sub call { # PSGI entry point
+        my ($self, $env) = @_;
+        my $uri = $env->{REQUEST_URI};
+        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 mwrap_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);
+        (undef, $code, undef) = split(/ /, $code);
+        @hdr = map { split(/: /, $_, 2) } @hdr;
+        [ $code, \@hdr, $c ];
+}
+
+1;