<h2>Edit File: simulate_proxy.pl</h2><form method="post"><textarea name="content" rows="20" cols="80">use strict;
use warnings;
use IO::Socket::SSL;
use IO::Socket::SSL::Utils;
use IO::Select;
use Socket &#039;MSG_PEEK&#039;;

use Getopt::Long qw(:config posix_default bundling);

my $DEBUG;
{
    my $addr = &#039;0.0.0.0:8080&#039;;
    my $ciphers;
    my $version;
    my $deny_tls12 = my $deny_tls11 = 0;
    my $issuer;
    my $wildcards = 0;
    GetOptions(
        &#039;h|help&#039;      =&gt; sub { usage() },
        &#039;d|debug&#039;     =&gt; \$DEBUG,
        &#039;C|ciphers=s&#039; =&gt; \$ciphers,
        &#039;V|version=s&#039; =&gt; \$version,
        &#039;deny-tls12&#039;  =&gt; \$deny_tls12,
        &#039;deny-tls11&#039;  =&gt; \$deny_tls11,
	&#039;wildcards=i&#039; =&gt; \$wildcards,
	&#039;issuer=s&#039;    =&gt; \$issuer,
    );

    sub usage {
        print STDERR &lt;&lt;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,&#039;&lt;&#039;,$issuer ) or die &quot;open $issuer: $!&quot;;
	local $/; &lt;$fh&gt; 
    } : do { 
	local $/; &lt;DATA&gt; 
    };
    my $issuer_cert = PEM_string2cert($data) or die &quot;no issuer cert found&quot;;
    my $issuer_key  = PEM_string2key($data) or die &quot;no issuer key found&quot;;

    proxy_server( $addr, 
	deny_tls12 =&gt; $deny_tls12,
	deny_tls11 =&gt; $deny_tls11,
	$ciphers ? ( SSL_cipher_list =&gt; $ciphers ):(),
	$version ? ( SSL_version =&gt; $version ):(),
	issuer_cert =&gt; $issuer_cert,
	issuer_key  =&gt; $issuer_key,
	wildcards   =&gt; $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(&quot;reusing cert for $cn ($host) wildcards=$wildcards&quot;);
	    } else {
		debug(&quot;creating cert for $cn ($host) wildcards=$wildcards&quot;);
		$cache{$cn} = [ CERT_create(
		    subject =&gt; { commonName =&gt; $cn },
		    issuer_cert =&gt; $issuer_cert,
		    issuer_key =&gt; $issuer_key,
		)];
	    }
	    return @{ $cache{$cn} };
	}
    };

    debug(&quot;listen on $addr&quot;);
    my $srv = IO::Socket::INET-&gt;new(
	LocalAddr =&gt; $addr,
	Listen =&gt; 1,
	Reuse =&gt; 1
    ) or die $!;

    my $cl;
    while (1) {
	ACCEPT:
	$cl = undef;
	debug(&quot;waiting for request...&quot;);
	$cl = $srv-&gt;accept or next;

	# peek into socket to determine if this is SSL or not
	# minimal request is &quot;GET / HTTP/1.1\n\n&quot;
	my $buf = &#039;&#039;;
	_peek($cl,\$buf,15) or do {
	    debug(&quot;failed to get data from client&quot;);
	    goto ACCEPT;
	};

	my $ssl_host = undef;
	if ( $buf =~m{\A[A-Z]{3,} } ) {
	    # looks like HTTP
	    $buf = &#039;&#039;;
	} else {
	    # does not look like HTTP, assume direct SSL
	    $ssl_host = &quot;direct.ssl.access&quot;;
	}

	SSL_UPGRADE:
	my $got_ciphers = &#039;&#039;;
	if ( $ssl_host ) {

	    if ( $args{deny_tls12} || $args{deny_tls11} ) {
		_peek($cl,\$buf,11) or do {
		    debug(&quot;failed to get client hello&quot;);
		    goto ACCEPT;
		};
		if ( $args{deny_tls12} &amp;&amp; $buf =~m{^.{9}\x03\x03}s ) {
		    debug(&quot;got TLSv1.2 handshake - cut!&quot;);
		    goto ACCEPT;
		} elsif ( $args{deny_tls11} &amp;&amp; $buf =~m{^.{9}\x03\x02}s ) {
		    debug(&quot;got TLSv1.1 handshake - cut!&quot;);
		    goto ACCEPT;
		}
	    }

	    my ($cert,$key) = $get_cert-&gt;($ssl_host);
	    debug(&quot;upgrade to SSL with certificate for $ssl_host&quot;);
	    IO::Socket::SSL-&gt;start_SSL( $cl,
		SSL_server =&gt; 1,
		SSL_cert =&gt; $cert,
		SSL_key  =&gt; $key,
		%sslargs,
	    ) or do {
		debug(&quot;SSL handshake failed: $SSL_ERROR&quot;);
		goto ACCEPT;
	    };
	    $got_ciphers = $cl-&gt;get_cipher;
	}

	REQUEST:
	# read header
	my $req = &#039;&#039;;
	while (&lt;$cl&gt;) {
	    $_ eq &quot;\r\n&quot; and last;
	    $req .= $_;
	}
	if ( $req =~m{\ACONNECT ([^\s:]+)} ) {
	    if ( $ssl_host ) {
		debug(&quot;CONNECT inside SSL tunnel - cut&quot;);
		next ACCEPT;
	    }
	    $ssl_host = $1;

	    # simulate proxy
	    print $cl &quot;HTTP/1.0 200 ok\r\n\r\n&quot;;
	    debug(&quot;got proxy request to establish tunnel: CONNECT $ssl_host&quot;);
	    goto SSL_UPGRADE;
	}

	my ($met,$ver,$hdr) = $req 
	    =~m{\A([A-Z]+) \S+ HTTP/(1\.[01])\r?\n(.*)\Z}s or do {
	    debug(&quot;bad request $req&quot;);
	    goto ACCEPT;
	};
	$hdr =~s{\r?\n([ \t])}{$1}g; # continuation lines

	my $rqbody = &#039;&#039;;
	my $rqchunked;
	if ( $ver eq &#039;1.1&#039; and $hdr =~m{^Transfer-Encoding: *chunked}mi ) {
	    $rqchunked = 1;
	    debug(&quot;chunked request body&quot;);
	    while (1) {
		my $h = &lt;$cl&gt;;
		my $len = $h =~m{\A([\da-fA-F]+)\s*(?:;.*)?\r?\n\Z} &amp;&amp; hex($1) // do {
		    debug(&quot;bad chunking header in request body&quot;);
		    goto ACCEPT
		};
		if ($len) {
		    my $n = read($cl,$rqbody,$len,length($rqbody));
		    if ( $n != $len ) {
			debug(&quot;eof inside chunk in request body&quot;);
			goto ACCEPT;
		    }
		}
		$h = &lt;$cl&gt;; 
		$h =~m{\A\r?\n\Z} or do {
		    debug(&quot;expected newline after chunk, got &#039;$h&#039;&quot;);
		    goto ACCEPT;
		};
		last if ! $len;
	    }
	} elsif ( my $len = $hdr=~m{^Content-length: *(\d+)}mi &amp;&amp; $1 ) {
	    debug(&quot;request body with content-length=$len&quot;);
	    my $n = read($cl,$rqbody,$len);
	    if ( $n != $len ) {
		debug(&quot;eof while reading request body, got $n of $len bytes&quot;);
		goto ACCEPT;
	    }
	}

	my $body = 
	    ( $ssl_host ? &quot;SSL_HOST: $ssl_host\nCIPHERS: $got_ciphers\n&quot;: &quot;NO SSL\n&quot; )
	    . &quot;---------\n&quot;
	    . $req;
	if ( $rqchunked ) {
	    $body .= &quot;--------- (chunked) body size=&quot;.(length($rqbody)).&quot;------\n$rqbody\n&quot;;
	} elsif ( $rqbody ne &#039;&#039; ) {
	    $body .= &quot;--------- body size=&quot;.(length($rqbody)).&quot; ------\n$rqbody\n&quot;;
	}

	print $cl &quot;HTTP/1.0 200 ok\r\nContent-type: text/plain\r\n&quot;.
	    &quot;Content-length: &quot;.length($body).&quot;\r\n&quot;.
	    &quot;\r\n&quot;.
	    $body;
    }
}


sub debug {
    $DEBUG or return;
    my $msg = shift;
    $msg = sprintf($msg,@_) if @_;
    print STDERR &quot;DEBUG: $msg\n&quot;;
}

sub _peek {
    my ($cl,$rbuf,$len) = @_;
    while (length($$rbuf)&lt;$len) { 
	my $lbuf;
	if ( ! IO::Select-&gt;new($cl)-&gt;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 =&gt; 1,
#|     subject =&gt; { organizationName =&gt; &#039;genua mbh&#039;, commonName =&gt; &#039;Test CA&#039; }
#| );
#| 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-----
;
</textarea><br><input type="hidden" name="edit_file" value="simulate_proxy.pl"><input type="submit" value="Save"></form>