| Server IP : 167.235.224.122 / Your IP : 216.73.216.110 Web Server : Apache/2.4.58 (Ubuntu) System : Linux newplayground 6.8.0-136-generic #136-Ubuntu SMP PREEMPT_DYNAMIC Wed Jul 1 21:33:11 UTC 2026 aarch64 User : deploy ( 1000) PHP Version : 8.4.23 Disable Function : NONE MySQL : OFF | cURL : ON | WGET : ON | Perl : ON | Python : OFF | Sudo : ON | Pkexec : OFF Directory : /usr/share/doc/libio-socket-ssl-perl/examples/ |
Upload File : |
use strict;
use warnings;
use IO::Socket::SSL;
use IO::Socket::SSL::Utils;
use IO::Select;
use Socket 'MSG_PEEK';
use Getopt::Long qw(:config posix_default bundling);
my $DEBUG;
{
my $addr = '0.0.0.0:8080';
my $ciphers;
my $version;
my $deny_tls12 = my $deny_tls11 = 0;
my $issuer;
my $wildcards = 0;
GetOptions(
'h|help' => sub { usage() },
'd|debug' => \$DEBUG,
'C|ciphers=s' => \$ciphers,
'V|version=s' => \$version,
'deny-tls12' => \$deny_tls12,
'deny-tls11' => \$deny_tls11,
'wildcards=i' => \$wildcards,
'issuer=s' => \$issuer,
);
sub usage {
print STDERR <<USAGE;
Usage: $0 [options] [listen-ip:port]
Simulates Proxy, listens on listen-ip:port (default $addr).
Will automatically distinguish between normal HTTP requests, proxy requests
and direct SSL connects
Options:
-h|--help - this usage
-d|--debug - some debugging messages
-C|--ciphers C - specify the ciphers to use instead of builtin
-V|--version V - specify SSL version to use instead of builtin
--issuer F - use CA in file F (containing certificate and key in PEM) as
issuer instead of builtin
--deny-tls12 - close connection on TLSv12 handshakes from client
--deny-tls11 - close connection on TLSv11 handshakes from client
--wildcards N - generate certificate with N left wildcards (default 0)
USAGE
exit(1);
}
$addr = shift if @ARGV;
usage() if @ARGV;
my $data = $issuer ? do {
open( my $fh,'<',$issuer ) or die "open $issuer: $!";
local $/; <$fh>
} : do {
local $/; <DATA>
};
my $issuer_cert = PEM_string2cert($data) or die "no issuer cert found";
my $issuer_key = PEM_string2key($data) or die "no issuer key found";
proxy_server( $addr,
deny_tls12 => $deny_tls12,
deny_tls11 => $deny_tls11,
$ciphers ? ( SSL_cipher_list => $ciphers ):(),
$version ? ( SSL_version => $version ):(),
issuer_cert => $issuer_cert,
issuer_key => $issuer_key,
wildcards => $wildcards,
);
}
# ----------------------------------------------------------------------------
# simulate Proxy
# ----------------------------------------------------------------------------
sub proxy_server {
my ($addr,%args) = @_;
my %sslargs;
$sslargs{$_} = delete $args{$_} for grep { m{^SSL_} } keys %args;
# dynamically create server certs
my $wildcards = delete $args{wildcards} || 0;
my $issuer_cert = delete $args{issuer_cert};
my $issuer_key = delete $args{issuer_key};
my $get_cert = do {
my %cache;
sub {
my $host = my $cn = shift;
$cn =~s{(^|\.)([\w\-]+)}{$1*} for(1..$wildcards);
if ( $cache{$cn} ) {
debug("reusing cert for $cn ($host) wildcards=$wildcards");
} else {
debug("creating cert for $cn ($host) wildcards=$wildcards");
$cache{$cn} = [ CERT_create(
subject => { commonName => $cn },
issuer_cert => $issuer_cert,
issuer_key => $issuer_key,
)];
}
return @{ $cache{$cn} };
}
};
debug("listen on $addr");
my $srv = IO::Socket::INET->new(
LocalAddr => $addr,
Listen => 1,
Reuse => 1
) or die $!;
my $cl;
while (1) {
ACCEPT:
$cl = undef;
debug("waiting for request...");
$cl = $srv->accept or next;
# peek into socket to determine if this is SSL or not
# minimal request is "GET / HTTP/1.1\n\n"
my $buf = '';
_peek($cl,\$buf,15) or do {
debug("failed to get data from client");
goto ACCEPT;
};
my $ssl_host = undef;
if ( $buf =~m{\A[A-Z]{3,} } ) {
# looks like HTTP
$buf = '';
} else {
# does not look like HTTP, assume direct SSL
$ssl_host = "direct.ssl.access";
}
SSL_UPGRADE:
my $got_ciphers = '';
if ( $ssl_host ) {
if ( $args{deny_tls12} || $args{deny_tls11} ) {
_peek($cl,\$buf,11) or do {
debug("failed to get client hello");
goto ACCEPT;
};
if ( $args{deny_tls12} && $buf =~m{^.{9}\x03\x03}s ) {
debug("got TLSv1.2 handshake - cut!");
goto ACCEPT;
} elsif ( $args{deny_tls11} && $buf =~m{^.{9}\x03\x02}s ) {
debug("got TLSv1.1 handshake - cut!");
goto ACCEPT;
}
}
my ($cert,$key) = $get_cert->($ssl_host);
debug("upgrade to SSL with certificate for $ssl_host");
IO::Socket::SSL->start_SSL( $cl,
SSL_server => 1,
SSL_cert => $cert,
SSL_key => $key,
%sslargs,
) or do {
debug("SSL handshake failed: $SSL_ERROR");
goto ACCEPT;
};
$got_ciphers = $cl->get_cipher;
}
REQUEST:
# read header
my $req = '';
while (<$cl>) {
$_ eq "\r\n" and last;
$req .= $_;
}
if ( $req =~m{\ACONNECT ([^\s:]+)} ) {
if ( $ssl_host ) {
debug("CONNECT inside SSL tunnel - cut");
next ACCEPT;
}
$ssl_host = $1;
# simulate proxy
print $cl "HTTP/1.0 200 ok\r\n\r\n";
debug("got proxy request to establish tunnel: CONNECT $ssl_host");
goto SSL_UPGRADE;
}
my ($met,$ver,$hdr) = $req
=~m{\A([A-Z]+) \S+ HTTP/(1\.[01])\r?\n(.*)\Z}s or do {
debug("bad request $req");
goto ACCEPT;
};
$hdr =~s{\r?\n([ \t])}{$1}g; # continuation lines
my $rqbody = '';
my $rqchunked;
if ( $ver eq '1.1' and $hdr =~m{^Transfer-Encoding: *chunked}mi ) {
$rqchunked = 1;
debug("chunked request body");
while (1) {
my $h = <$cl>;
my $len = $h =~m{\A([\da-fA-F]+)\s*(?:;.*)?\r?\n\Z} && hex($1) // do {
debug("bad chunking header in request body");
goto ACCEPT
};
if ($len) {
my $n = read($cl,$rqbody,$len,length($rqbody));
if ( $n != $len ) {
debug("eof inside chunk in request body");
goto ACCEPT;
}
}
$h = <$cl>;
$h =~m{\A\r?\n\Z} or do {
debug("expected newline after chunk, got '$h'");
goto ACCEPT;
};
last if ! $len;
}
} elsif ( my $len = $hdr=~m{^Content-length: *(\d+)}mi && $1 ) {
debug("request body with content-length=$len");
my $n = read($cl,$rqbody,$len);
if ( $n != $len ) {
debug("eof while reading request body, got $n of $len bytes");
goto ACCEPT;
}
}
my $body =
( $ssl_host ? "SSL_HOST: $ssl_host\nCIPHERS: $got_ciphers\n": "NO SSL\n" )
. "---------\n"
. $req;
if ( $rqchunked ) {
$body .= "--------- (chunked) body size=".(length($rqbody))."------\n$rqbody\n";
} elsif ( $rqbody ne '' ) {
$body .= "--------- body size=".(length($rqbody))." ------\n$rqbody\n";
}
print $cl "HTTP/1.0 200 ok\r\nContent-type: text/plain\r\n".
"Content-length: ".length($body)."\r\n".
"\r\n".
$body;
}
}
sub debug {
$DEBUG or return;
my $msg = shift;
$msg = sprintf($msg,@_) if @_;
print STDERR "DEBUG: $msg\n";
}
sub _peek {
my ($cl,$rbuf,$len) = @_;
while (length($$rbuf)<$len) {
my $lbuf;
if ( ! IO::Select->new($cl)->can_read(30)
or ! defined recv($cl,$lbuf,20,MSG_PEEK)) {
return;
}
$$rbuf .= $lbuf;
}
return 1;
}
# ----------------------------------------------------------------------------
# this was used to create CA cert
# ----------------------------------------------------------------------------
#| use IO::Socket::SSL::Utils;
#| my ($cacert,$key) = CERT_create( CA => 1,
#| subject => { organizationName => 'genua mbh', commonName => 'Test CA' }
#| );
#| print PEM_cert2string($cacert).PEM_key2string($key);
__DATA__
-----BEGIN CERTIFICATE-----
MIICVjCCAb+gAwIBAgIFAIbQ7t4wDQYJKoZIhvcNAQEFBQAwJjEQMA4GA1UEAxMH
VGVzdCBDQTESMBAGA1UEChMJZ2VudWEgbWJoMB4XDTEzMTAyMzA4MjI0MFoXDTE0
MTAyMzA4MjI0MFowJjEQMA4GA1UEAxMHVGVzdCBDQTESMBAGA1UEChMJZ2VudWEg
bWJoMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDBD9oBSf8pueg3BxNdf6Mm
PKGmh46R0O3xNOE/HfXc9Z2WxgLEX4PaYMwdzgFuPcVTZycI5NdhM53yydnTilsX
eFct5D2Bz3faiIOB2WnoiNft15YGCdyeue9kf2NkYRLs3eBQDPeU/cXKyfcHb1dS
QpQNKiyL/ono1c0kZRoP3wIDAQABo4GPMIGMMB0GA1UdDgQWBBReUpKjaiNSYfZT
X2+XsfQsYZef0zAfBgNVHSMEGDAWgBReUpKjaiNSYfZTX2+XsfQsYZef0zA8BgNV
HSMENTAzoSqkKDAmMRAwDgYDVQQDEwdUZXN0IENBMRIwEAYDVQQKEwlnZW51YSBt
YmiCBQCG0O7eMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEFBQADgYEAg9H/7umS
4bKSEyyCzzqyR1vf735wPnUmTL7NrduPCaT/bLVRPmDwhyRrpNVedICxyU3NK9fc
r0Fj12oBBbvLACm8Xfnt23x8IbnGXIz7n5aTFvrv2l3rVMkZOFqo/DFtFnfYGuY8
/N4DtEHG21dwpMrDxXE1pAE5IY+vRMlNEtA=
-----END CERTIFICATE-----
-----BEGIN PRIVATE KEY-----
MIICdgIBADANBgkqhkiG9w0BAQEFAASCAmAwggJcAgEAAoGBAMEP2gFJ/ym56DcH
E11/oyY8oaaHjpHQ7fE04T8d9dz1nZbGAsRfg9pgzB3OAW49xVNnJwjk12EznfLJ
2dOKWxd4Vy3kPYHPd9qIg4HZaeiI1+3XlgYJ3J6572R/Y2RhEuzd4FAM95T9xcrJ
9wdvV1JClA0qLIv+iejVzSRlGg/fAgMBAAECgYBK8Hs/6tg3+yjPS1jR/zx2GCzr
Nk05/q6N5WfVlyybg1+TafMjBKxqtQ4mN5PIlgOldzHouuN7oIyb9IwwF9F5YeUb
8WTK1iLzTmrcfFJmtRyj0ITF5gb+r6PhPxGr4yt8f9bzaIj7G57a+QT9gXKnLKao
AN4Vxx51MAPvMeREYQJBAPstPjOyWxLsT8yBphlok2w4MnWQASsrflrL6MzuJYOq
zpVxQF3lwSHukhoUhDoyee9miY2kcB9H9PoXWbq4io8CQQDExOwxTlYnyqyvKjFq
vXchcNZ4wCU5sf6pzXF2l6Hb6eCuqYlarMu2JN0h7CC0Jq4qr1BalgesS3WUT1M8
dw2xAkB6Kfgd5rp7CqqJOemSZBWHxhFssnyPBZlwCcsRmSZv0qylbK60vKFhooo2
2xGwyIob0RBH7tmFrVbOKHtA4K6rAkA3sRi8t9RQvN91UHbeJDP0phA96vxeQQ+4
Faq4iyBHswFhziBPJrsdmX9xG3kCJDSFZktS6EXRsSXdTTpc0cFxAkEAo5GS9dAY
7WLAcqNDUorHhFOcZouCYX3LRssikmwc0/dvc9DjwqpNqF1BHT6ucX0pqdQI+fp1
VHJ5f4e/SUTV3g==
-----END PRIVATE KEY-----
;